Context Navigation

strings_mod.f90 @ 5456

Last change on this file since 5456 was 5353, checked in by yann meurdesoif, 4 weeks ago
Nvidia compiler has some difficulties to compile correctly some complex array constructor. This commit decompose it the several phases in order to achieve the compilation. Please Lionel and David, have a look to this in order to validate. Probably, in future, when compiler heuristic will be improved, this commit can be reversed. YM
File size: 93.3 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)
[5267]	55	USE ioipsl, ONLY: getin
[5001]	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)
[5267]	65	USE ioipsl, ONLY: getin
[5001]	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)
[5267]	75	USE ioipsl, ONLY: getin
[5001]	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)
[5267]	85	USE ioipsl, ONLY: getin
[5001]	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
[5353]	815	IF(nc /= 1) THEN
	816	!ym fix for nvidia compiler
	817	!ym out = [s0(1:nc-1), tmp]
	818	out = s0(1:nc-1)
	819	out = [out , tmp]
	820	ENDIF
[5001]	821	END FUNCTION horzcat_s10
	822	!==============================================================================================================================
	823	FUNCTION horzcat_s11(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
	824	IMPLICIT NONE
	825	CHARACTER(LEN=*), INTENT(IN) :: s0(:)
	826	CHARACTER(LEN=*), OPTIONAL, TARGET, INTENT(IN) :: s1(:), s2(:), s3(:), s4(:), s5(:), s6(:), s7(:), s8(:), s9(:)
[4046]	827	CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:)
[5001]	828	CHARACTER(LEN=maxlen), POINTER :: s(:)
	829	INTEGER :: nrow, ncol, iv, n
	830	LOGICAL :: pre(9)
[4349]	831	!------------------------------------------------------------------------------------------------------------------------------
[5001]	832	pre(:) = [PRESENT(s1),PRESENT(s2),PRESENT(s3),PRESENT(s4),PRESENT(s5),PRESENT(s6),PRESENT(s7),PRESENT(s8),PRESENT(s9)]
	833	nrow = SIZE(s0)
	834	ncol = 1+COUNT(pre)
[4046]	835	ALLOCATE(out(nrow, ncol))
[5001]	836	out(:,1) = s0
	837	DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
	838	SELECT CASE(iv-1)
	839	CASE(1); s=> s1; CASE(2); s=> s2; CASE(3); s=> s3; CASE(4); s=> s4; CASE(5); s=> s5
	840	CASE(6); s=> s6; CASE(7); s=> s7; CASE(8); s=> s8; CASE(9); s=> s9
[4046]	841	END SELECT
	842	n = SIZE(s, DIM=1)
[5001]	843	IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
[4046]	844	out(:,iv) = s(:)
	845	END DO
[5001]	846	END FUNCTION horzcat_s11
[4046]	847	!==============================================================================================================================
[5001]	848	FUNCTION horzcat_s21(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
	849	IMPLICIT NONE
	850	CHARACTER(LEN=*), INTENT(IN) :: s0(:,:), s1(:)
	851	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s2(:), s3(:), s4(:), s5(:), s6(:), s7(:), s8(:), s9(:)
[5353]	852	CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:), tmp(:,:), pk(:)
[5001]	853	INTEGER :: nc
	854	nc = SIZE(s0, 2)
	855	tmp = horzcat_s11(s0(:,nc), s1, s2, s3, s4, s5, s6, s7, s8, s9)
[5003]	856	IF(nc == 1) out = tmp
[5353]	857	!ym fix for nvidia compiler
	858	!ym IF(nc /= 1) out = RESHAPE([PACK(s0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(s0, 1), nc + SIZE(tmp, 2)-1])
	859	IF(nc /= 1) THEN
	860	pk = PACK(s0(:,1:nc-1), .TRUE.)
	861	pk = [ pk, PACK(tmp, .TRUE.)]
	862	out = RESHAPE(pk, SHAPE=[SIZE(s0, 1), nc + SIZE(tmp, 2)-1])
	863	ENDIF
[5001]	864	END FUNCTION horzcat_s21
	865	!==============================================================================================================================
	866	FUNCTION horzcat_i00(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
	867	IMPLICIT NONE
	868	INTEGER, INTENT(IN) :: i0
[4046]	869	INTEGER, OPTIONAL, TARGET, INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7, i8, i9
	870	INTEGER, ALLOCATABLE :: out(:)
[5001]	871	INTEGER, POINTER :: i
	872	INTEGER :: ncol, iv
	873	LOGICAL :: pre(9)
[4349]	874	!------------------------------------------------------------------------------------------------------------------------------
[5001]	875	pre(:) = [PRESENT(i1),PRESENT(i2),PRESENT(i3),PRESENT(i4),PRESENT(i5),PRESENT(i6),PRESENT(i7),PRESENT(i8),PRESENT(i9)]
	876	ncol = SIZE(pre)
	877	ALLOCATE(out(ncol))
	878	out(1) = i0
	879	DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
	880	SELECT CASE(iv-1)
	881	CASE(1); i=> i1; CASE(2); i=> i2; CASE(3); i=> i3; CASE(4); i=> i4; CASE(5); i=> i5
	882	CASE(6); i=> i6; CASE(7); i=> i7; CASE(8); i=> i8; CASE(9); i=> i9
[4046]	883	END SELECT
	884	out(iv) = i
	885	END DO
[5001]	886	END FUNCTION horzcat_i00
[4046]	887	!==============================================================================================================================
[5001]	888	FUNCTION horzcat_i10(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
	889	IMPLICIT NONE
	890	INTEGER, INTENT(IN) :: i0(:), i1
	891	INTEGER, OPTIONAL, INTENT(IN) :: i2, i3, i4, i5, i6, i7, i8, i9
	892	INTEGER, ALLOCATABLE :: out(:), tmp(:)
	893	INTEGER :: nc
	894	nc = SIZE(i0)
	895	tmp = horzcat_i00(i0(nc), i1, i2, i3, i4, i5, i6, i7, i8, i9)
[5003]	896	IF(nc == 1) out = tmp
	897	IF(nc /= 1) out = [i0(1:nc-1), tmp]
[5001]	898	END FUNCTION horzcat_i10
	899	!==============================================================================================================================
	900	FUNCTION horzcat_i11(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
	901	IMPLICIT NONE
	902	INTEGER, INTENT(IN) :: i0(:)
	903	INTEGER, OPTIONAL, TARGET, INTENT(IN) :: i1(:), i2(:), i3(:), i4(:), i5(:), i6(:), i7(:), i8(:), i9(:)
[4046]	904	INTEGER, ALLOCATABLE :: out(:,:)
[5001]	905	INTEGER, POINTER :: i(:)
	906	INTEGER :: nrow, ncol, iv, n
	907	LOGICAL :: pre(9)
[4349]	908	!------------------------------------------------------------------------------------------------------------------------------
[5001]	909	pre(:) = [PRESENT(i1),PRESENT(i2),PRESENT(i3),PRESENT(i4),PRESENT(i5),PRESENT(i6),PRESENT(i7),PRESENT(i8),PRESENT(i9)]
	910	nrow = SIZE(i0)
	911	ncol = 1+COUNT(pre)
[4046]	912	ALLOCATE(out(nrow, ncol))
[5001]	913	out(:,1) = i0
	914	DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
	915	SELECT CASE(iv-1)
	916	CASE(1); i=> i1; CASE(2); i=> i2; CASE(3); i=> i3; CASE(4); i=> i4; CASE(5); i=> i5
	917	CASE(6); i=> i6; CASE(7); i=> i7; CASE(8); i=> i8; CASE(9); i=> i9
[4046]	918	END SELECT
	919	n = SIZE(i, DIM=1)
[5001]	920	IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
[4046]	921	out(:,iv) = i(:)
	922	END DO
[5001]	923	END FUNCTION horzcat_i11
[4046]	924	!==============================================================================================================================
[5001]	925	FUNCTION horzcat_i21(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
	926	IMPLICIT NONE
	927	INTEGER, INTENT(IN) :: i0(:,:), i1(:)
	928	INTEGER, OPTIONAL, INTENT(IN) :: i2(:), i3(:), i4(:), i5(:), i6(:), i7(:), i8(:), i9(:)
	929	INTEGER, ALLOCATABLE :: out(:,:), tmp(:,:)
	930	INTEGER :: nc
	931	nc = SIZE(i0, 2)
	932	tmp = horzcat_i11(i0(:,nc), i1, i2, i3, i4, i5, i6, i7, i8, i9)
[5003]	933	IF(nc == 1) out = tmp
	934	IF(nc /= 1) out = RESHAPE([PACK(i0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(i0, 1), nc + SIZE(tmp, 2)-1])
[5001]	935	END FUNCTION horzcat_i21
	936	!==============================================================================================================================
	937	FUNCTION horzcat_r00(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
	938	IMPLICIT NONE
	939	REAL, INTENT(IN) :: r0
[4046]	940	REAL, OPTIONAL, TARGET, INTENT(IN) :: r1, r2, r3, r4, r5, r6, r7, r8, r9
	941	REAL, ALLOCATABLE :: out(:)
[5001]	942	REAL, POINTER :: r
	943	INTEGER :: ncol, iv
	944	LOGICAL :: pre(9)
[4349]	945	!------------------------------------------------------------------------------------------------------------------------------
[5001]	946	pre(:) = [PRESENT(r1),PRESENT(r2),PRESENT(r3),PRESENT(r4),PRESENT(r5),PRESENT(r6),PRESENT(r7),PRESENT(r8),PRESENT(r9)]
	947	ncol = 1+COUNT(pre)
	948	ALLOCATE(out(ncol))
	949	out(1) = r0
	950	DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
	951	SELECT CASE(iv-1)
	952	CASE(1); r=> r1; CASE(2); r=> r2; CASE(3); r=> r3; CASE(4); r=> r4; CASE(5); r=> r5
	953	CASE(6); r=> r6; CASE(7); r=> r7; CASE(8); r=> r8; CASE(9); r=> r9
[4046]	954	END SELECT
	955	out(iv) = r
	956	END DO
[5001]	957	END FUNCTION horzcat_r00
[4046]	958	!==============================================================================================================================
[5001]	959	FUNCTION horzcat_r10(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
	960	IMPLICIT NONE
	961	REAL, INTENT(IN) :: r0(:), r1
	962	REAL, OPTIONAL, INTENT(IN) :: r2, r3, r4, r5, r6, r7, r8, r9
	963	REAL, ALLOCATABLE :: out(:), tmp(:)
	964	INTEGER :: nc
	965	nc = SIZE(r0)
	966	tmp = horzcat_r00(r0(nc), r1, r2, r3, r4, r5, r6, r7, r8, r9)
[5003]	967	IF(nc == 1) out = tmp
	968	IF(nc /= 1) out = [r0(1:nc-1), tmp]
[5001]	969	END FUNCTION horzcat_r10
	970	!==============================================================================================================================
	971	FUNCTION horzcat_r11(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
	972	IMPLICIT NONE
	973	REAL, INTENT(IN) :: r0(:)
	974	REAL, OPTIONAL, TARGET, INTENT(IN) :: r1(:), r2(:), r3(:), r4(:), r5(:), r6(:), r7(:), r8(:), r9(:)
[4046]	975	REAL, ALLOCATABLE :: out(:,:)
[5001]	976	REAL, POINTER :: r(:)
	977	INTEGER :: nrow, ncol, iv, n
	978	LOGICAL :: pre(9)
[4349]	979	!------------------------------------------------------------------------------------------------------------------------------
[5001]	980	pre(:) = [PRESENT(r1),PRESENT(r2),PRESENT(r3),PRESENT(r4),PRESENT(r5),PRESENT(r6),PRESENT(r7),PRESENT(r8),PRESENT(r9)]
	981	nrow = SIZE(r0)
	982	ncol = 1+COUNT(pre)
[4046]	983	ALLOCATE(out(nrow, ncol))
[5001]	984	out(:,1) = r0
	985	DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
	986	SELECT CASE(iv-1)
	987	CASE(1); r=> r1; CASE(2); r=> r2; CASE(3); r=> r3; CASE(4); r=> r4; CASE(5); r=> r5
	988	CASE(6); r=> r5; CASE(7); r=> r7; CASE(8); r=> r8; CASE(9); r=> r9
[4046]	989	END SELECT
	990	n = SIZE(r, DIM=1)
[5001]	991	IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
[4046]	992	out(:,iv) = r(:)
	993	END DO
[5001]	994	END FUNCTION horzcat_r11
[4046]	995	!==============================================================================================================================
[5001]	996	FUNCTION horzcat_r21(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
	997	IMPLICIT NONE
	998	REAL, INTENT(IN) :: r0(:,:), r1(:)
	999	REAL, OPTIONAL, INTENT(IN) :: r2(:), r3(:), r4(:), r5(:), r6(:), r7(:), r8(:), r9(:)
	1000	REAL, ALLOCATABLE :: out(:,:), tmp(:,:)
	1001	INTEGER :: nc
	1002	nc = SIZE(r0, 2)
	1003	tmp = horzcat_r11(r0(:,nc), r1, r2, r3, r4, r5, r6, r7, r8, r9)
[5003]	1004	IF(nc == 1) out = tmp
	1005	IF(nc /= 1) out = RESHAPE([PACK(r0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(r0, 1), nc + SIZE(tmp, 2)-1])
[5001]	1006	END FUNCTION horzcat_r21
	1007	!==============================================================================================================================
	1008	FUNCTION horzcat_d00(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
	1009	IMPLICIT NONE
	1010	DOUBLE PRECISION, INTENT(IN) :: d0
[4046]	1011	DOUBLE PRECISION, OPTIONAL, TARGET, INTENT(IN) :: d1, d2, d3, d4, d5, d6, d7, d8, d9
	1012	DOUBLE PRECISION, ALLOCATABLE :: out(:)
[5001]	1013	DOUBLE PRECISION, POINTER :: d
	1014	INTEGER :: ncol, iv
	1015	LOGICAL :: pre(9)
[4349]	1016	!------------------------------------------------------------------------------------------------------------------------------
[5001]	1017	pre(:) = [PRESENT(d1),PRESENT(d2),PRESENT(d3),PRESENT(d4),PRESENT(d5),PRESENT(d6),PRESENT(d7),PRESENT(d8),PRESENT(d9)]
	1018	ncol = 1+COUNT(pre)
	1019	ALLOCATE(out(ncol))
	1020	out(1) = d0
	1021	DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
	1022	SELECT CASE(iv-1)
	1023	CASE(1); d=> d1; CASE(2); d=> d2; CASE(3); d=> d3; CASE(4); d=> d4; CASE(5); d=> d5
	1024	CASE(6); d=> d6; CASE(7); d=> d7; CASE(8); d=> d8; CASE(9); d=> d9
[4046]	1025	END SELECT
	1026	out(iv) = d
	1027	END DO
[5001]	1028	END FUNCTION horzcat_d00
[4046]	1029	!==============================================================================================================================
[5001]	1030	FUNCTION horzcat_d10(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
	1031	IMPLICIT NONE
	1032	DOUBLE PRECISION, INTENT(IN) :: d0(:), d1
	1033	DOUBLE PRECISION, OPTIONAL, INTENT(IN) :: d2, d3, d4, d5, d6, d7, d8, d9
	1034	DOUBLE PRECISION, ALLOCATABLE :: out(:), tmp(:)
	1035	INTEGER :: nc
	1036	nc = SIZE(d0)
	1037	tmp = horzcat_d00(d0(nc), d1, d2, d3, d4, d5, d6, d7, d8, d9)
[5003]	1038	IF(nc == 1) out = tmp
	1039	IF(nc /= 1) out = [d0(1:nc-1), tmp]
[5001]	1040	END FUNCTION horzcat_d10
	1041	!==============================================================================================================================
	1042	FUNCTION horzcat_d11(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
	1043	IMPLICIT NONE
	1044	DOUBLE PRECISION, INTENT(IN) :: d0(:)
	1045	DOUBLE PRECISION, OPTIONAL, TARGET, INTENT(IN) :: d1(:), d2(:), d3(:), d4(:), d5(:), d6(:), d7(:), d8(:), d9(:)
[4046]	1046	DOUBLE PRECISION, ALLOCATABLE :: out(:,:)
[5001]	1047	DOUBLE PRECISION, POINTER :: d(:)
	1048	INTEGER :: nrow, ncol, iv, n
	1049	LOGICAL :: pre(9)
[4349]	1050	!------------------------------------------------------------------------------------------------------------------------------
[5001]	1051	nrow = SIZE(d0)
	1052	pre(:) = [PRESENT(d1),PRESENT(d2),PRESENT(d3),PRESENT(d4),PRESENT(d5),PRESENT(d6),PRESENT(d7),PRESENT(d8),PRESENT(d9)]
	1053	ncol = 1+COUNT(pre)
[4046]	1054	ALLOCATE(out(nrow, ncol))
[5001]	1055	DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
	1056	SELECT CASE(iv-1)
	1057	CASE(1); d=> d1; CASE(2); d=> d2; CASE(3); d=> d3; CASE(4); d=> d4; CASE(5); d=> d5
	1058	CASE(6); d=> d6; CASE(7); d=> d7; CASE(8); d=> d8; CASE(9); d=> d9
[4046]	1059	END SELECT
	1060	n = SIZE(d, DIM=1)
[5001]	1061	IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
[4046]	1062	out(:,iv) = d(:)
	1063	END DO
[5001]	1064	END FUNCTION horzcat_d11
[4046]	1065	!==============================================================================================================================
[5001]	1066	FUNCTION horzcat_d21(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
	1067	IMPLICIT NONE
	1068	DOUBLE PRECISION, INTENT(IN) :: d0(:,:), d1(:)
	1069	DOUBLE PRECISION, OPTIONAL, INTENT(IN) :: d2(:), d3(:), d4(:), d5(:), d6(:), d7(:), d8(:), d9(:)
	1070	DOUBLE PRECISION, ALLOCATABLE :: out(:,:), tmp(:,:)
	1071	INTEGER :: nc
	1072	nc = SIZE(d0, 2)
	1073	tmp = horzcat_d11(d0(:,nc), d1, d2, d3, d4, d5, d6, d7, d8, d9)
[5003]	1074	IF(nc == 1) out = tmp
	1075	IF(nc /= 1) out = RESHAPE([PACK(d0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(d0, 1), nc + SIZE(tmp, 2)-1])
[5001]	1076	END FUNCTION horzcat_d21
	1077	!==============================================================================================================================
[4046]	1078
	1079
	1080	!==============================================================================================================================
	1081	!--- Display a clean table composed of successive vectors of same length.
	1082	!=== The profile "p" describe in which order to pick up the columns from "s", "i" and "r" for display.
[4193]	1083	!=== * nRowMax lines are displayed (default: all lines)
	1084	!=== * nColMax characters (default: as long as needed) are displayed at most on a line. If the effective total length is
	1085	!=== higher, several partial tables are displayed ; the nHead (default: 1) first columns are included in each sub-table.
[4046]	1086	!==============================================================================================================================
[4193]	1087	LOGICAL FUNCTION dispTable(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr)
[5001]	1088	IMPLICIT NONE
[4046]	1089	CHARACTER(LEN=*), INTENT(IN) :: p !--- DISPLAY MAP: s/i/r
	1090	CHARACTER(LEN=*), INTENT(IN) :: titles(:) !--- TITLES (ONE EACH COLUMN)
	1091	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s(:,:) !--- STRINGS
	1092	INTEGER, OPTIONAL, INTENT(IN) :: i(:,:) !--- INTEGERS
	1093	REAL, OPTIONAL, INTENT(IN) :: r(:,:) !--- REALS
	1094	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: rFmt !--- Format for reals
[4193]	1095	INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Display at most "nRowMax" rows
	1096	INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Display at most "nColMax" characters each line
	1097	INTEGER, OPTIONAL, INTENT(IN) :: nHead !--- Head columns repeated for multiple tables display
[4046]	1098	INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (default: screen)
[4120]	1099	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub !--- Subroutine name
[4349]	1100	!------------------------------------------------------------------------------------------------------------------------------
[4046]	1101	CHARACTER(LEN=2048) :: row
[4120]	1102	CHARACTER(LEN=maxlen) :: rFm, el, subn
[4046]	1103	CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:)
	1104	CHARACTER(LEN=1) :: s1, sp
[4193]	1105	INTEGER :: is, ii, ir, it, k, nmx, unt, ic, np
	1106	INTEGER :: ns, ni, nr, nt, l, ncol, nHd, ib, l0
	1107	INTEGER, ALLOCATABLE :: n(:), ncmx(:)
	1108	INTEGER, PARAMETER :: nm=1 !--- Space between values & columns
[4046]	1109	LOGICAL :: ls, li, lr
[4120]	1110	subn = ''; IF(PRESENT(sub)) subn = sub
[4046]	1111	rFm = '*'; IF(PRESENT(rFmt)) rFm = rFmt !--- Specified format for reals
	1112	unt = lunout; IF(PRESENT(unit)) unt = unit !--- Specified output unit
	1113	np = LEN_TRIM(p); ns = 0; ni = 0; nr = 0; ncol = 0
	1114	ls = PRESENT(s); li = PRESENT(i); lr = PRESENT(r)
	1115	lerr = .FALSE.; IF(.NOT.ANY([ls,li,lr])) RETURN !--- Nothing to do
	1116	sp = '\|' !--- Separator
	1117
	1118	!--- CHECK ARGUMENTS COHERENCE
[4193]	1119	lerr = np /= SIZE(titles); IF(fmsg('display map "p" length and titles list mismatch', subn, lerr)) RETURN
[4120]	1120	IF(ls) THEN
	1121	ns = SIZE(s, 1); ncol = ncol + SIZE(s, 2); lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, 2)
[4046]	1122	END IF
[4120]	1123	IF(li) THEN
	1124	ni = SIZE(i, 1); ncol = ncol + SIZE(i, 2); lerr = COUNT([(p(ic:ic)=='i', ic=1, np)]) /= SIZE(i, 2)
[4046]	1125	END IF
[4120]	1126	IF(lr) THEN
	1127	nr = SIZE(r, 1); ncol = ncol + SIZE(r, 2); lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, 2)
[4046]	1128	END IF
[4193]	1129	IF(fmsg('display map "p" length and arguments number mismatch', subn, lerr)) RETURN
[4120]	1130	lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', subn, lerr)) RETURN
	1131	lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', subn, lerr)) RETURN
	1132	lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg( 'string and real arguments lengths mismatch', subn, lerr)) RETURN
	1133	lerr = li.AND.lr.AND.ni/=nr; IF(fmsg( 'integer and real arguments lengths mismatch', subn, lerr)) RETURN
[4193]	1134	nmx = MAX(ns,ni,nr)+1; IF(PRESENT(nRowMax)) nmx = MIN(nmx,nRowMax+1)
[4046]	1135
	1136	!--- Allocate the assembled quantities array
[4193]	1137	ALLOCATE(d(nmx,ncol), n(ncol))
[4046]	1138
	1139	!--- Assemble the vectors into a strings array in the order indicated by "pattern"
	1140	is = 1; ii = 1; ir = 1
	1141	DO ic = 1, ncol
	1142	d(1,ic) = TRIM(titles(ic))
	1143	SELECT CASE(p(ic:ic))
	1144	CASE('s'); d(2:nmx,ic) = s(:,is) ; is = is + 1
	1145	CASE('i'); d(2:nmx,ic) = int2str(i(:,ii) ); ii = ii + 1
	1146	CASE('r'); d(2:nmx,ic) = real2str(r(:,ir),rFm); ir = ir + 1
	1147	END SELECT
[4193]	1148	END DO
	1149	CALL cleanZeros(d)
	1150	DO ic = 1, ncol
[4046]	1151	n(ic)=0; DO ir=1, nmx; n(ic)=MAX(n(ic), LEN_TRIM(d(ir,ic))); END DO
	1152	END DO
	1153	n(:) = n(:) + 2*nm
	1154
[4193]	1155	!--- Build the vector of max column index in case the rows are too long (table must be displayed in multiple parts)
	1156	nHd = 1; IF(PRESENT(nHead)) nHd = nHead
	1157	IF(.NOT.PRESENT(nColMax)) THEN
	1158	nt = 1; ncmx = [ncol]
	1159	ELSE
	1160	nt = 1; l0 = SUM(n(1:nHd)+1)+1
	1161	IF(PRESENT(sub)) l0=l0+LEN_TRIM(subn)+1
	1162	!--- Count the number of table parts
	1163	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
	1164	!--- Get the index of the last column for each table part
	1165	ALLOCATE(ncmx(nt)); k = 1
	1166	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
	1167	ncmx(nt) = ncol
	1168	END IF
	1169
[4046]	1170	!--- Display the strings array as a table
[4193]	1171	DO it = 1, nt
	1172	DO ir = 1, nmx; row = ''
	1173	DO ic = 1, nHd; el = d(ir,ic)
	1174	s1 = sp
	1175	row = TRIM(row)//REPEAT(' ',nm)//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el)-nm)//s1
	1176	END DO
	1177	ib = nHd+1; IF(it>1) ib = ncmx(it-1)+1
	1178	DO ic = ib, ncmx(it); el = d(ir,ic)
	1179	s1 = sp
	1180	row = TRIM(row)//REPEAT(' ',nm)//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el)-nm)//s1
	1181	END DO
	1182	nr = LEN_TRIM(row)-1 !--- Final separator removed
	1183	CALL msg(row(1:nr), subn, unit=unt)
[4349]	1184	IF(ir /= 1) CYCLE !--- Titles only are underlined
[4193]	1185	row=''; DO ic=1,nHd; row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO
	1186	DO ic = ib,ncmx(it); row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO
	1187	CALL msg(row(1:LEN_TRIM(row)-1), subn, unit=unt)
[4046]	1188	END DO
[4193]	1189	CALL msg('', subn, unit=unt)
[4046]	1190	END DO
	1191
	1192	END FUNCTION dispTable
	1193	!==============================================================================================================================
	1194
	1195	!==============================================================================================================================
	1196	LOGICAL FUNCTION dispNamelist(unt, p, titles, s, i, r, rFmt, llast) RESULT(lerr)
[5001]	1197	IMPLICIT NONE
[4046]	1198	INTEGER, INTENT(IN) :: unt !--- Output unit
	1199	CHARACTER(LEN=*), INTENT(IN) :: p !--- DISPLAY MAP: s/i/r
	1200	CHARACTER(LEN=*), INTENT(IN) :: titles(:) !--- TITLES (ONE EACH COLUMN)
	1201	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s(:,:) !--- STRINGS
	1202	INTEGER, OPTIONAL, INTENT(IN) :: i(:,:) !--- INTEGERS
	1203	REAL, OPTIONAL, INTENT(IN) :: r(:,:) !--- REALS
	1204	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: rFmt !--- Format for reals
	1205	LOGICAL, OPTIONAL, INTENT(IN) :: llast !--- Last variable: no final ','
[4349]	1206	!------------------------------------------------------------------------------------------------------------------------------
[4046]	1207	CHARACTER(LEN=maxlen) :: rFm, el
	1208	CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:)
	1209	CHARACTER(LEN=:), ALLOCATABLE :: sp, row
	1210	INTEGER :: is, ii, ir, nrow, ic
	1211	INTEGER :: ns, ni, nr, ncol, np
	1212	INTEGER, ALLOCATABLE :: n(:)
	1213	LOGICAL :: ls, li, lr, la
	1214	rFm = '*'; IF(PRESENT(rFmt)) rFm = rFmt !--- Specified format for reals
	1215	ls = PRESENT(s); li = PRESENT(i); lr = PRESENT(r)
	1216	lerr = .FALSE.; IF(.NOT.ANY([ls,li,lr])) RETURN !--- Nothing to do
	1217	la = .FALSE.; IF(PRESENT(llast)) la = llast
	1218
	1219	!--- CHECK ARGUMENTS COHERENCE
	1220	ns = 0; ni = 0; nr = 0; np = LEN_TRIM(p); ncol = 0
	1221	IF(ls) THEN; ns = SIZE(s, DIM=1); ncol = ncol + SIZE(s, DIM=2)
	1222	lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, DIM=2)
	1223	END IF
	1224	IF(li) THEN; ni = SIZE(i, DIM=1); ncol = ncol + SIZE(i, DIM=2)
	1225	lerr = COUNT([(p(ic:ic)=='i', ic=1, np)]) /= SIZE(i, DIM=2)
	1226	END IF
	1227	IF(lr) THEN; nr = SIZE(r, DIM=1); ncol = ncol + SIZE(r, DIM=2)
	1228	lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, DIM=2)
	1229	END IF
[4193]	1230	IF(fmsg('display map "p" length and arguments number mismatch', ll=lerr)) RETURN
[4046]	1231	lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', ll=lerr)) RETURN
	1232	lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', ll=lerr)) RETURN
	1233	lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg( 'string and real arguments lengths mismatch', ll=lerr)) RETURN
	1234	lerr = li.AND.lr.AND.ni/=nr; IF(fmsg( 'integer and real arguments lengths mismatch', ll=lerr)) RETURN
	1235
	1236	!--- Allocate the assembled quantities array
	1237	nrow = MAX(ns,ni,nr)+1
	1238	ALLOCATE(d(nrow,ncol), n(ncol))
	1239
	1240	!--- Assemble the vectors into a strings array in the order indicated by "pattern"
	1241	is = 1; ii = 1; ir = 1
	1242	DO ic = 1, ncol
	1243	d(1,ic) = TRIM(titles(ic))
	1244	SELECT CASE(p(ic:ic))
	1245	CASE('s'); d(2:nrow,ic) = s(:,is) ; is = is + 1
	1246	CASE('i'); d(2:nrow,ic) = int2str(i(:,ii) ); ii = ii + 1
	1247	CASE('r'); d(2:nrow,ic) = real2str(r(:,ir),rFm); ir = ir + 1
	1248	END SELECT
[4193]	1249	END DO
	1250	CALL cleanZeros(d)
	1251	DO ic = 1, ncol
[4046]	1252	n(ic) = 0; DO ir=1, nrow; n(ic)=MAX(n(ic), LEN_TRIM(d(ir,ic))); END DO
	1253	IF(needQuotes(d(2,ic)) .AND. ic/=1) n(ic) = n(ic) + 2 !--- For quotes, using second line only
	1254	END DO
	1255
	1256	!--- Display the strings array as a table
	1257	DO ir = 1, nrow
	1258	row = ''; sp = ' '; IF(TRIM(d(ir,1)) /= '') sp = ' = '
	1259	DO ic = 1, ncol
	1260	el = d(ir,ic); IF(ic /= 1) el = addQuotes_1(el)
	1261	row = row//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el))//sp
	1262	sp = ' '; IF(ic /= ncol-1) CYCLE
	1263	IF(TRIM(d(MIN(ir+1,nrow),1)) /= '' .AND. (ir /= nrow .OR. .NOT.la)) sp = ' , '
	1264	END DO
	1265	WRITE(unt,'(a)')TRIM(row)
	1266	END DO
	1267
	1268	!--- End of section
	1269	IF(la) THEN
	1270	WRITE(unt,'(a)')'/'
	1271	WRITE(unt,'(a)')
	1272	END IF
	1273
	1274	END FUNCTION dispNameList
	1275	!==============================================================================================================================
	1276
	1277
	1278	!==============================================================================================================================
[4193]	1279	LOGICAL FUNCTION dispOutliers_1(ll, a, n, err_msg, nam, subn, nRowmax, nColMax, nHead, unit) RESULT(lerr)
[5001]	1280	IMPLICIT NONE
[4046]	1281	! Display outliers list in tables
	1282	! If "nam" is supplied, it means the last index is for tracers => one table each tracer for rank > 2.
	1283	LOGICAL, INTENT(IN) :: ll(:) !--- Linearized mask of outliers
	1284	REAL, INTENT(IN) :: a(:) !--- Linearized array of values
	1285	INTEGER, INTENT(IN) :: n(:) !--- Profile before linearization
	1286	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_msg, nam(:), subn !--- Error message, variables and calling subroutine names
[4193]	1287	INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Maximum number of lines to display (default: all)
	1288	INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Maximum number of characters per line (default: 2048)
	1289	INTEGER, OPTIONAL, INTENT(IN) :: nHead !--- Number of front columns to duplicate (default: 1)
	1290	INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (def: lunout)
[4349]	1291	!------------------------------------------------------------------------------------------------------------------------------
[4046]	1292	CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:)
	1293	LOGICAL, ALLOCATABLE :: m(:)
	1294	INTEGER, ALLOCATABLE :: ki(:), kj(:)
[4193]	1295	INTEGER :: i, j, k, rk, rk1, ib, ie, itr, nm, unt, nRmx, nCmx, nHd, nv
[4046]	1296	CHARACTER(LEN=maxlen) :: mes, sub, fm='(f12.9)', v, s
	1297	CHARACTER(LEN=maxlen), ALLOCATABLE :: vnm(:)
	1298
	1299	lerr = ANY(ll); IF(.NOT.lerr) RETURN !--- No outliers -> finished
	1300
	1301	mes = 'outliers found'; IF(PRESENT(err_msg)) mes = err_msg !--- Error message
	1302	vnm = ['a']; IF(PRESENT(nam )) vnm = nam !--- Variables names
	1303	sub = 'dispOutliers'; IF(PRESENT(subn)) sub = subn !--- Calling subroutine name
[4193]	1304	nRmx= SIZE(a); IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)!-- Maximum number of lines to print
	1305	nCmx= 2048; IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)!-- Maximum number of characters each line
	1306	nHd = 1; IF(PRESENT(nHead)) nHd = nHead !--- Number of front columns to duplicate
[4046]	1307	unt = lunout; IF(PRESENT(unit)) unt = unit !--- Unit to print messages
	1308
	1309	rk = SIZE(n); nv = SIZE(vnm)
[5001]	1310	lerr = nv/=1 .AND. nv/=n(rk); CALL msg('SIZE(nam) /= 1 and /= last "n" element', sub, lerr); IF(lerr) RETURN
	1311	lerr = SIZE(a) /= SIZE(ll); CALL msg('ll" and "a" sizes mismatch', sub, lerr); IF(lerr) RETURN
	1312	lerr = SIZE(a) /= PRODUCT(n); CALL msg('profile "n" does not match "a" and "ll', sub, lerr); IF(lerr) RETURN
[4046]	1313	CALL msg(mes, sub, unit=unt)
	1314
	1315	!--- SCALAR CASE: single value to display
	1316	IF(rk==1.AND.n(1)==1) THEN
	1317	IF(ll(1)) WRITE(unt,'(a," = ",f12.9)')TRIM(nam(1)),a(1); RETURN
	1318	END IF
	1319
	1320	rk1 = rk; IF(nv==1) rk1 = rk-1 !--- Rank of each displayed table
	1321	SELECT CASE(rk1) !--- Indices list
	1322	CASE(1,2); ki = [ (i,i=1,n(1)) ]
	1323	CASE(3); ki = [((i,i=1,n(1)),j=1,n(2))]; kj = [((j,i=1,n(1)),j=1,n(2))]
	1324	CASE DEFAULT; WRITE(unt,*)'Sorry: routine "dispOutliers" is limited to rank 3'; RETURN
	1325	END SELECT
	1326
	1327	!--- VECTOR CASE: table " name \| value " (known names) / ) / " i \| a(i) " (unknown names)
	1328	IF(rk==1) THEN
	1329	ALLOCATE(ttl(2)); ttl(2) = TRIM(vnm(1))//'(i)'; ttl(1) = 'i'
[4193]	1330	IF(nv == 1) lerr = dispTable('sr', ttl, s=cat(PACK(nam,ll)), r=cat(PACK(a,ll)), &
	1331	rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
	1332	IF(nv /= 1) lerr = dispTable('ir', ['name ','value'], i=cat(PACK(ki,m)), r=cat(PACK(a,ll)), &
	1333	rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
[4046]	1334	CALL msg("can't display outliers table", sub, lerr, unt)
	1335	RETURN
	1336	END IF
	1337
	1338	!--- OTHER CASES: one table for each tracer (last index)
	1339	ttl = [(ACHAR(k), k = 105, 104+rk)] !--- Titles list ('i', 'j', 'k'...)
	1340	s = strStack( ttl(1:rk-1) ) !--- Tracer name dummy indexes: (i, j, k, ...
	1341
	1342	DO itr=1,n(rk)
	1343	nm = PRODUCT(n(1:rk-1)) !--- number of elements per tracer
	1344	ie = itr*nm; ib = ie-nm+1; m=ll(ib:ie) !--- section bounds for tracer "itr" ; outlayers mask
	1345	IF(.NOT.ANY(m)) CYCLE !--- no outlayers for tracer "itr"
	1346	v = TRIM(vnm(MIN(itr,SIZE(vnm))))//'('//TRIM(s) !--- "<name>("
	1347	IF(nv == 1) ttl(rk) = TRIM(v)//','//int2str(itr)//')' !--- "<name>(i,j,itr)" (single name)
	1348	IF(nv /= 1) ttl(rk) = TRIM(v)//')' !--- "<nam(itr)>(i,j)" (one name each table/itr index)
[4193]	1349	IF(rk==2) lerr = dispTable('ir', ttl, i=cat(PACK(ki,m)), r=cat(PACK(a(ib:ie),m)), &
	1350	rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
	1351	IF(rk==3) lerr = dispTable('iir', ttl, i=cat(PACK(ki,m),PACK(kj,m)), r=cat(PACK(a(ib:ie),m)), &
	1352	rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
[4046]	1353	CALL msg("can't display outliers table", sub, lerr, unt)
	1354	IF(lerr) RETURN
	1355	END DO
	1356	END FUNCTION dispOutliers_1
	1357	!==============================================================================================================================
[4193]	1358	LOGICAL FUNCTION dispOutliers_2(ll, a, n, err_msg, nam, subn, nRowMax, nColMax, nHead, unit) RESULT(lerr)
[5001]	1359	IMPLICIT NONE
[4046]	1360	! Display outliers list in tables
	1361	! If "nam" is supplied and, it means the last index is for tracers => one table each tracer for rank > 2.
	1362	LOGICAL, INTENT(IN) :: ll(:) !--- Linearized mask of outliers
	1363	REAL, INTENT(IN) :: a(:,:) !--- Linearized arrays of values stacked along 2nd dim.
	1364	INTEGER, INTENT(IN) :: n(:) !--- Profile before linearization
	1365	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_msg, nam(:), subn !--- Error message, variables and calling subroutine names
[4193]	1366	INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Maximum number of lines to display (default: all)
	1367	INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Maximum number of characters per line (default: 2048)
	1368	INTEGER, OPTIONAL, INTENT(IN) :: nHead !--- Number of front columns to duplicate (default: 1)
	1369	INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (def: lunout)
[4349]	1370	!------------------------------------------------------------------------------------------------------------------------------
[4046]	1371	CHARACTER(LEN=maxlen) :: mes, sub, fm='(f12.9)', prf
	1372	CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:), vnm(:)
	1373	INTEGER, ALLOCATABLE :: ki(:), kj(:), kl(:)
[4363]	1374	INTEGER :: i, j, k, rk, nv, unt, nRmx, nCmx, nHd
[4046]	1375	REAL, ALLOCATABLE :: val(:,:)
	1376
[4193]	1377	lerr = ANY(ll); IF(.NOT.lerr) RETURN !--- No outliers -> finished
[4046]	1378	rk = SIZE(n); nv = SIZE(a,2)
[4193]	1379	mes = 'outliers found'; IF(PRESENT(err_msg)) mes = err_msg !--- Error message
	1380	vnm = [(ACHAR(k+96),k=1,nv)]; IF(PRESENT(nam )) vnm = nam !--- Variables names
	1381	sub = 'dispOutliers'; IF(PRESENT(subn)) sub = subn !--- Calling subroutine name
	1382	nRmx= SIZE(a); IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)!-- Maximum number of lines to print
	1383	nCmx= 2048; IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)!-- Maximum number of characters each line
	1384	nHd = 1; IF(PRESENT(nHead)) nHd = nHead !--- Number of front columns to duplicate
	1385	unt = lunout; IF(PRESENT(unit)) unt = unit !--- Unit to print messages
	1386	lerr= SIZE(vnm) /= nv; IF(fmsg('SIZE(nam) /= SIZE(a,2)', sub, lerr, unt)) RETURN
	1387	lerr= SIZE(a,1) /= SIZE(ll); IF(fmsg('"ll" and "a" sizes mismatch', sub, lerr, unt)) RETURN
	1388	lerr= SIZE(a,1) /= PRODUCT(n); IF(fmsg('profile "n" does not match "a" and "ll"', sub, lerr, unt)) RETURN
[4046]	1389
[4363]	1390	SELECT CASE(rk) !--- Indices list
[4046]	1391	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
	1392	CASE(1); ki = [ (i,i=1,n(1)) ]
	1393	CASE(2); ki = [ ((i,i=1,n(1)),j=1,n(2))]; kj = [ ((j,i=1,n(1)),j=1,n(2))]
	1394	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))]
	1395	kl = [(((k,i=1,n(1)),j=1,n(2)),k=1,n(3))]
	1396	CASE DEFAULT; WRITE(unt,*)'Sorry: routine "dispOutliers_2" is limited to rank 3'; RETURN
	1397	END SELECT
	1398
	1399	ttl = [(ACHAR(k), k = 105, 104+rk), vnm] !--- Titles list ('i', 'j', 'k'...'var1', 'var2', ...)
	1400	prf = REPEAT('i',rk)//REPEAT('r',nv) !--- Profile
	1401	ALLOCATE(val(COUNT(ll),nv)); DO k=1, nv; val(:,k) = PACK(a(:,k),ll); END DO
[4193]	1402	IF(rk == 1) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll)), r = val, &
	1403	rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
	1404	IF(rk == 2) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll)), r = val, &
	1405	rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
	1406	IF(rk == 3) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll),PACK(kl,ll)), r = val, &
	1407	rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
[4046]	1408	CALL msg("can't display outliers table", sub, lerr, unt)
	1409	END FUNCTION dispOutliers_2
	1410	!==============================================================================================================================
	1411
	1412
	1413	!==============================================================================================================================
	1414	!=== Reduce an algebrical expression (basic operations and parenthesis) to a single number (string format) ====================
	1415	!==============================================================================================================================
	1416	LOGICAL FUNCTION reduceExpr_1(str, val) RESULT(lerr)
[5001]	1417	IMPLICIT NONE
[4046]	1418	CHARACTER(LEN=*), INTENT(IN) :: str
	1419	CHARACTER(LEN=maxlen), INTENT(OUT) :: val
[4349]	1420	!------------------------------------------------------------------------------------------------------------------------------
[4046]	1421	CHARACTER(LEN=maxlen) :: v
	1422	CHARACTER(LEN=1024) :: s, vv
	1423	CHARACTER(LEN=1024), ALLOCATABLE :: vl(:)
	1424	INTEGER, ALLOCATABLE :: ip(:)
	1425	INTEGER :: nl, nn, i, j, im, ix
	1426	LOGICAL :: ll
	1427	s = str
	1428
	1429	!--- Check wether the parenthesis are correctly formed
	1430	ll = strCount(s,'(',nl)
	1431	ll = strCount(s,')',nn)
	1432	lerr = nl /= nn
	1433	IF(fmsg('Mismatching number of opening and closing parenthesis: '//TRIM(s), ll=lerr)) RETURN
	1434	nl = 2*nl-1
	1435
	1436	!--- Build vectors ; vl: parenthesis-separated elements ; ip: parenthesis types (1: opening, 2: closing)
	1437	ALLOCATE(ip(nl-1),vl(nl))
	1438	j = 1; im = 1
	1439	DO i = 1, LEN_TRIM(str)
	1440	ix = INDEX('()', str(i:i))
	1441	IF(ix == 0) CYCLE
	1442	ip(j) = ix
	1443	vl(j) = str(im:i-1)
	1444	j = j + 1; im = i + 1
	1445	END DO
	1446	vl(j) = str(im:LEN_TRIM(str))
	1447
	1448	!--- Search for each opening/closing parenthesis pair
	1449	DO WHILE(nl > 1)
	1450	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]	1451	lerr = reduceExpr_basic(vl(i+1), v); IF(lerr) RETURN
[4046]	1452	v = TRIM(vl(i))//TRIM(v); IF(i+2<=nl) v=TRIM(v)//TRIM(vl(i+2))
	1453	vv = v//REPEAT(' ',768)
	1454	IF(i == 1) THEN; ip = ip(3:nl-1); vl = [ vv, vl(4 :nl)]
	1455	ELSE IF(i == nl-1) THEN; ip = ip(1:nl-2); vl = [vl(1:nl-3), vv ]
	1456	ELSE; ip = [ip(1: i-1), ip(i+2:nl-1)]; vl = [vl(1: i-1), vv, vl(i+3:nl)]; END IF
	1457	nl = SIZE(vl)
	1458	END DO
	1459	lerr = reduceExpr_basic(vl(1), val)
	1460	END FUNCTION reduceExpr_1
	1461
	1462
	1463	!==============================================================================================================================
	1464	!=== Reduce a simple algebrical expression (basic operations, no parenthesis) to a single number (string format) ==============
	1465	!==============================================================================================================================
	1466	LOGICAL FUNCTION reduceExpr_basic(str, val) RESULT(lerr)
[5001]	1467	IMPLICIT NONE
[4046]	1468	CHARACTER(LEN=*), INTENT(IN) :: str
	1469	CHARACTER(LEN=*), INTENT(OUT) :: val
	1470	DOUBLE PRECISION, ALLOCATABLE :: vl(:)
	1471	INTEGER, ALLOCATABLE :: id(:)
	1472	CHARACTER(LEN=maxlen), ALLOCATABLE :: ky(:)
	1473	CHARACTER(LEN=1), ALLOCATABLE :: op(:)
[4349]	1474	!------------------------------------------------------------------------------------------------------------------------------
[4046]	1475	CHARACTER(LEN=1024) :: s
	1476	DOUBLE PRECISION :: v, vm, vp
	1477	INTEGER :: i, ni, io
	1478	lerr = .FALSE.
	1479	IF(is_numeric(str)) THEN; val=TRIM(str); RETURN; END IF
	1480	op = ['^','/','*','+','-'] !--- List of recognized operations
	1481	s = str
[5001]	1482	lerr = strParse_m(s, op, ky, lSc=.TRUE., id = id) !--- Parse the values
	1483	IF(lerr) RETURN !--- Problem with the parsing
[4046]	1484	vl = str2dble(ky) !--- Conversion to doubles
	1485	lerr = ANY(vl >= HUGE(1.d0))
[5001]	1486	CALL msg('Some values are non-numeric in: '//TRIM(s), ll=lerr)
	1487	IF(lerr) RETURN !--- Non-numerical values found
[4046]	1488	DO io = 1, SIZE(op) !--- Loop on known operators (order matters !)
	1489	DO i = SIZE(id), 1, -1 !--- Loop on found operators
	1490	ni = SIZE(id)
	1491	IF(id(i) /= io) CYCLE !--- Current found operator is not op(io)
	1492	vm = vl(i); vp = vl(i+1) !--- Couple of values used for current operation
[5001]	1493	SELECT CASE(op(io)) !--- Perform operation on the two values
[4349]	1494	CASE('^'); v = vm**vp
	1495	CASE('/'); v = vm/vp
	1496	CASE(''); v = vmvp
	1497	CASE('+'); v = vm+vp
	1498	CASE('-'); v = vm-vp
[4046]	1499	END SELECT
	1500	IF(i == ni) THEN; vl = [vl(1:ni-1), v]; ELSE; vl = [vl(1:i-1), v, vl(i+2:ni+1)]; END IF
	1501	IF(i == ni) THEN; id = id(1:ni-1); ELSE; id = [id(1:i-1), id(i+1:ni )]; END IF
	1502	END DO
	1503	END DO
	1504	val = dble2str(vl(1))
	1505
	1506	END FUNCTION reduceExpr_basic
	1507	!==============================================================================================================================
	1508
	1509	!==============================================================================================================================
	1510	FUNCTION reduceExpr_m(str, val) RESULT(lerr)
[5001]	1511	IMPLICIT NONE
[4046]	1512	LOGICAL, ALLOCATABLE :: lerr(:)
	1513	CHARACTER(LEN=*), INTENT(IN) :: str(:)
	1514	CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
[4349]	1515	!------------------------------------------------------------------------------------------------------------------------------
[4046]	1516	INTEGER :: i
	1517	ALLOCATE(lerr(SIZE(str)),val(SIZE(str)))
	1518	lerr(:) = [(reduceExpr_1(str(i), val(i)), i=1, SIZE(str))]
	1519	END FUNCTION reduceExpr_m
	1520	!==============================================================================================================================
	1521
	1522
	1523	!==============================================================================================================================
	1524	!=== Check whether a string is a number or not ================================================================================
	1525	!==============================================================================================================================
	1526	ELEMENTAL LOGICAL FUNCTION is_numeric(str) RESULT(out)
[5001]	1527	IMPLICIT NONE
[4046]	1528	CHARACTER(LEN=*), INTENT(IN) :: str
	1529	REAL :: x
	1530	INTEGER :: e
	1531	CHARACTER(LEN=12) :: fmt
	1532	IF(TRIM(str) == '') THEN; out = .FALSE.; RETURN; END IF
	1533	WRITE(fmt,'("(f",i0,".0)")') LEN_TRIM(str)
	1534	READ(str,fmt,IOSTAT=e) x
	1535	out = e==0 .AND. INDEX('Ee',str(LEN_TRIM(str):LEN_TRIM(str)))==0
	1536	END FUNCTION is_numeric
	1537	!==============================================================================================================================
	1538
	1539
	1540	!==============================================================================================================================
	1541	!=== Convert a string into a logical/integer integer or an integer/real into a string =========================================
	1542	!==============================================================================================================================
[4987]	1543	ELEMENTAL INTEGER FUNCTION str2bool(str) RESULT(out) !--- Result: 0/1 for .FALSE./.TRUE., -1 if not a valid boolean
	1544	IMPLICIT NONE
[4046]	1545	CHARACTER(LEN=*), INTENT(IN) :: str
	1546	INTEGER :: ierr
[4987]	1547	LOGICAL :: lout
	1548	READ(str,*,IOSTAT=ierr) lout
	1549	out = -HUGE(1)
	1550	IF(ierr /= 0) THEN
	1551	IF(ANY(['.false.', 'false ', 'no ', 'f ', 'n '] == strLower(str))) out = 0
	1552	IF(ANY(['.true. ', 'true ', 'yes ', 't ', 'y '] == strLower(str))) out = 1
	1553	ELSE
	1554	out = 0; IF(lout) out = 1
	1555	END IF
[4046]	1556	END FUNCTION str2bool
	1557	!==============================================================================================================================
	1558	ELEMENTAL INTEGER FUNCTION str2int(str) RESULT(out)
[5001]	1559	IMPLICIT NONE
[4046]	1560	CHARACTER(LEN=*), INTENT(IN) :: str
	1561	INTEGER :: ierr
	1562	READ(str,*,IOSTAT=ierr) out
	1563	IF(ierr/=0) out = -HUGE(1)
	1564	END FUNCTION str2int
	1565	!==============================================================================================================================
	1566	ELEMENTAL REAL FUNCTION str2real(str) RESULT(out)
[5001]	1567	IMPLICIT NONE
[4046]	1568	CHARACTER(LEN=*), INTENT(IN) :: str
	1569	INTEGER :: ierr
	1570	READ(str,*,IOSTAT=ierr) out
	1571	IF(ierr/=0) out = -HUGE(1.)
	1572	END FUNCTION str2real
	1573	!==============================================================================================================================
	1574	ELEMENTAL DOUBLE PRECISION FUNCTION str2dble(str) RESULT(out)
[5001]	1575	IMPLICIT NONE
[4046]	1576	CHARACTER(LEN=*), INTENT(IN) :: str
	1577	INTEGER :: ierr
	1578	READ(str,*,IOSTAT=ierr) out
	1579	IF(ierr/=0) out = -HUGE(1.d0)
	1580	END FUNCTION str2dble
	1581	!==============================================================================================================================
	1582	ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION bool2str(b) RESULT(out)
[5001]	1583	IMPLICIT NONE
[4046]	1584	LOGICAL, INTENT(IN) :: b
	1585	WRITE(out,*)b
	1586	out = ADJUSTL(out)
	1587	END FUNCTION bool2str
	1588	!==============================================================================================================================
	1589	ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION int2str(i, nDigits) RESULT(out)
[5001]	1590	IMPLICIT NONE
[4046]	1591	INTEGER, INTENT(IN) :: i
	1592	INTEGER, OPTIONAL, INTENT(IN) :: nDigits
[4349]	1593	!------------------------------------------------------------------------------------------------------------------------------
[4046]	1594	WRITE(out,*)i
	1595	out = ADJUSTL(out)
	1596	IF(.NOT.PRESENT(nDigits)) RETURN
	1597	IF(nDigits > LEN_TRIM(out)) out = REPEAT('0', nDigits - LEN_TRIM(out))//TRIM(out)
	1598	END FUNCTION int2str
	1599	!==============================================================================================================================
	1600	ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION real2str(r,fmt) RESULT(out)
[5001]	1601	IMPLICIT NONE
[4046]	1602	REAL, INTENT(IN) :: r
	1603	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt
[4349]	1604	!------------------------------------------------------------------------------------------------------------------------------
[4046]	1605	IF( PRESENT(fmt)) WRITE(out,fmt)r
	1606	IF(.NOT.PRESENT(fmt)) WRITE(out, * )r
	1607	out = ADJUSTL(out)
	1608	END FUNCTION real2str
	1609	!==============================================================================================================================
	1610	ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION dble2str(d,fmt) RESULT(out)
[5001]	1611	IMPLICIT NONE
[4046]	1612	DOUBLE PRECISION, INTENT(IN) :: d
	1613	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt
[4349]	1614	!------------------------------------------------------------------------------------------------------------------------------
[4046]	1615	IF( PRESENT(fmt)) WRITE(out,fmt)d
	1616	IF(.NOT.PRESENT(fmt)) WRITE(out, * )d
	1617	out = ADJUSTL(out)
	1618	END FUNCTION dble2str
	1619	!==============================================================================================================================
[4193]	1620	ELEMENTAL SUBROUTINE cleanZeros(s)
[5001]	1621	IMPLICIT NONE
[4193]	1622	CHARACTER(LEN=*), INTENT(INOUT) :: s
	1623	INTEGER :: ls, ix, i
	1624	IF(is_numeric(s)) THEN
	1625	ls = LEN_TRIM(s)
	1626	ix = MAX(INDEX(s,'E'),INDEX(s,'e'),INDEX(s,'D'),INDEX(s,'d'))
	1627	IF(ix == 0) THEN
	1628	DO ix = ls,1,-1; IF(s(ix:ix) /= '0') EXIT; END DO; s=s(1:ix+1)
	1629	ELSE IF(INDEX(s,'.')/=0) THEN
	1630	i = ix-1; DO WHILE(s(i:i) == '0'); i = i-1; END DO; s=s(1:i)//s(ix:ls)
	1631	END IF
	1632	END IF
	1633	END SUBROUTINE cleanZeros
	1634	!==============================================================================================================================
[4046]	1635
[4349]	1636
[4046]	1637	!==============================================================================================================================
	1638	FUNCTION addQuotes_1(s) RESULT(out)
[5001]	1639	IMPLICIT NONE
[4046]	1640	CHARACTER(LEN=*), INTENT(IN) :: s
	1641	CHARACTER(LEN=:), ALLOCATABLE :: out
	1642	IF(needQuotes(s)) THEN; out = "'"//TRIM(s)//"'"; ELSE; out = s; END IF
	1643	END FUNCTION addQuotes_1
	1644	!==============================================================================================================================
	1645	FUNCTION addQuotes_m(s) RESULT(out)
[5001]	1646	IMPLICIT NONE
[4046]	1647	CHARACTER(LEN=*), INTENT(IN) :: s(:)
	1648	CHARACTER(LEN=:), ALLOCATABLE :: out(:)
[4349]	1649	!------------------------------------------------------------------------------------------------------------------------------
[4046]	1650	INTEGER :: k, n
	1651	n = MAXVAL(LEN_TRIM(s), MASK=.TRUE.)
	1652	ALLOCATE(CHARACTER(LEN=n) :: out(SIZE(s)))
	1653	DO k=1,SIZE(s)
	1654	IF(needQuotes(s(k))) THEN; out(k) = "'"//TRIM(s(k))//"'"; ELSE; out(k) = s(k); END IF
	1655	END DO
	1656	END FUNCTION addQuotes_m
	1657	!==============================================================================================================================
	1658	ELEMENTAL LOGICAL FUNCTION needQuotes(s) RESULT(out)
[5001]	1659	IMPLICIT NONE
[4046]	1660	CHARACTER(LEN=*), INTENT(IN) :: s
	1661	CHARACTER(LEN=1) :: b, e
[4349]	1662	!------------------------------------------------------------------------------------------------------------------------------
[4046]	1663	out = .TRUE.; IF(TRIM(s) == '') RETURN
	1664	b = s(1:1); e = s(MAX(1,LEN_TRIM(s)):MAX(1,LEN_TRIM(s)))
	1665	out = .NOT.is_numeric(s) .AND. (b /= "'" .OR. e /= "'") .AND. ( b /= '"' .OR. e /= '"')
	1666	END FUNCTION needQuotes
	1667	!==============================================================================================================================
	1668
	1669
	1670	!==============================================================================================================================
	1671	!=== DISPLAY "<message>: the following <items> are <reason>" FOLLOWED BY THE LIST OF <str> FOR WHICH <lerr>==T. ===============
	1672	!==============================================================================================================================
	1673	LOGICAL FUNCTION checkList(str, lerr, message, items, reason, nmax) RESULT(out)
[5001]	1674	IMPLICIT NONE
[4046]	1675	! Purpose: Messages in case a list contains wrong elements (indicated by lerr boolean vector).
	1676	! Note: Return value "out" is .TRUE. if there are errors (ie at least one element of "lerr" is TRUE).
	1677	CHARACTER(LEN=*), INTENT(IN) :: str(:)
	1678	LOGICAL, INTENT(IN) :: lerr(:)
	1679	CHARACTER(LEN=*), INTENT(IN) :: message, items, reason
	1680	INTEGER, OPTIONAL, INTENT(IN) :: nmax
[4349]	1681	!------------------------------------------------------------------------------------------------------------------------------
[4046]	1682	CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:)
	1683	INTEGER :: i, nmx
	1684	nmx = 256; IF(PRESENT(nmax)) nmx=nmax
	1685	out = ANY(lerr); IF(.NOT.out) RETURN
	1686	CALL msg(TRIM(message)//': the following '//TRIM(items)//' are '//TRIM(reason)//':')
	1687	s = strStackm(PACK(str, MASK=lerr), ', ',nmx)
	1688	DO i=1,SIZE(s,DIM=1); CALL msg(s(i)); END DO
	1689	END FUNCTION checkList
	1690	!==============================================================================================================================
	1691
	1692
	1693	!==============================================================================================================================
	1694	!=== Remove comment in line "str", ie all the characters from the first "#" sign found in "str". ==============================
	1695	!==============================================================================================================================
	1696	SUBROUTINE removeComment(str)
[5001]	1697	IMPLICIT NONE
[4046]	1698	CHARACTER(LEN=*), INTENT(INOUT) :: str
	1699	INTEGER :: ix
	1700	ix = INDEX(str,'# '); IF(ix /= 0) str = str(1:ix-1)//REPEAT(' ',LEN(str)-ix+1)
	1701	END SUBROUTINE removeComment
	1702	!==============================================================================================================================
	1703
	1704
	1705	END MODULE strings_mod

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

Download in other formats:

Original Format