Context Navigation

source: readTracFiles_mod.f90 @ 27

Last change on this file since 27 was 27, checked in by dcugnet, 22 months ago
Missing modifications in the previous commit.
File size: 130.2 KB

Line
1	MODULE readTracFiles_mod
2
3	USE strings_mod, ONLY: msg, find, get_in, str2int, dispTable, testFile, strReduce, strFind, strStack, strHead, &
4	test, removeComment, cat, fmsg, maxlen, int2str, checkList, strParse, strReplace, strTail, strCount, strIdx, reduceExpr
5
6	IMPLICIT NONE
7
8	PRIVATE
9
10	PUBLIC :: maxlen !--- PARAMETER FOR CASUAL STRING LENGTH
11	PUBLIC :: tracers !--- TRACERS DESCRIPTION DATABASE
12	PUBLIC :: trac_type, setGeneration, indexUpdate !--- TRACERS DESCRIPTION ASSOCIATED TOOLS
13	PUBLIC :: testTracersFiles, readTracersFiles !--- TRACERS FILES READING ROUTINES
14	PUBLIC :: getKey, fGetKey, fGetKeys, addKey, setDirectKeys !--- TOOLS TO GET/SET KEYS FROM/TO tracers & isotopes
15	PUBLIC :: getKeysDBase, setKeysDBase !--- TOOLS TO GET/SET THE DATABASE (tracers & isotopes)
16
17	PUBLIC :: addPhase, getiPhase, old_phases, phases_sep, & !--- FUNCTIONS RELATED TO THE PHASES
18	nphases, delPhase, getPhase, known_phases, phases_names !--- + ASSOCIATED VARIABLES
19
20	PUBLIC :: oldH2OIso, newH2OIso, old2newH2O, new2oldH2O !--- H2O ISOTOPES BACKWARD COMPATIBILITY (OLD traceur.def)
21	PUBLIC :: oldHNO3, newHNO3 !--- HNO3 REPRO BACKWARD COMPATIBILITY (OLD start.nc)
22
23	PUBLIC :: tran0, idxAncestor, ancestor !--- GENERATION 0 TRACER + TOOLS FOR GENERATIONS
24
25	!=== FOR ISOTOPES: GENERAL
26	PUBLIC :: isot_type, readIsotopesFile, isoSelect !--- ISOTOPES DESCRIPTION TYPE + READING ROUTINE
27	PUBLIC :: ixIso, nbIso !--- INDEX OF SELECTED ISOTOPES CLASS + NUMBER OF CLASSES
28
29	!=== FOR ISOTOPES: H2O FAMILY ONLY
30	PUBLIC :: iH2O
31
32	!=== FOR ISOTOPES: DEPENDING ON THE SELECTED ISOTOPES CLASS
33	PUBLIC :: isotope, isoKeys !--- SELECTED ISOTOPES DATABASE + ASSOCIATED KEYS
34	PUBLIC :: isoName, isoZone, isoPhas !--- ISOTOPES AND TAGGING ZONES NAMES AND PHASES
35	PUBLIC :: niso, nzone, nphas, ntiso !--- " " NUMBERS + ISOTOPES AND TAGGING TRACERS NUMBERS
36	PUBLIC :: itZonIso !--- Idx IN isoName(1:niso) = f(tagging idx, isotope idx)
37	PUBLIC :: iqIsoPha !--- Idx IN qx(1:nqtot) = f(isotope idx, phase idx)
38	PUBLIC :: isoCheck !--- FLAG TO RUN ISOTOPES CHECKING ROUTINES
39
40	PUBLIC :: maxTableWidth
41	!------------------------------------------------------------------------------------------------------------------------------
42	TYPE :: keys_type !=== TYPE FOR A SET OF KEYS ASSOCIATED TO AN ELEMENT
43	CHARACTER(LEN=maxlen) :: name !--- Tracer name
44	CHARACTER(LEN=maxlen), ALLOCATABLE :: key(:) !--- Keys string list
45	CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:) !--- Corresponding values string list
46	END TYPE keys_type
47	!------------------------------------------------------------------------------------------------------------------------------
48	TYPE :: trac_type !=== TYPE FOR A SINGLE TRACER NAMED "name"
49	CHARACTER(LEN=maxlen) :: name = '' !--- Name of the tracer
50	CHARACTER(LEN=maxlen) :: gen0Name = '' !--- First generation ancestor name
51	CHARACTER(LEN=maxlen) :: parent = '' !--- Parent name
52	CHARACTER(LEN=maxlen) :: longName = '' !--- Long name (with advection scheme suffix)
53	CHARACTER(LEN=maxlen) :: type = 'tracer' !--- Type (so far: 'tracer' / 'tag')
54	CHARACTER(LEN=maxlen) :: phase = 'g' !--- Phase ('g'as / 'l'iquid / 's'olid)
55	CHARACTER(LEN=maxlen) :: component = '' !--- Coma-separated list of components (Ex: lmdz,inca)
56	INTEGER :: iadv = 10 !--- Advection scheme used
57	INTEGER :: iGeneration = -1 !--- Generation number (>=0)
58	LOGICAL :: isAdvected = .FALSE. !--- "true" tracers: iadv > 0. COUNT(isAdvected )=nqtrue
59	LOGICAL :: isInPhysics = .TRUE. !--- "true" tracers: in tr_seri. COUNT(isInPhysics)=nqtottr
60	INTEGER :: iqParent = 0 !--- Parent index
61	INTEGER, ALLOCATABLE :: iqDescen(:) !--- Descendants index (in growing generation order)
62	INTEGER :: nqDescen = 0 !--- Number of descendants (all generations)
63	INTEGER :: nqChildren = 0 !--- Number of children (first generation)
64	INTEGER :: iso_iGroup = 0 !--- Isotopes group index in isotopes(:)
65	INTEGER :: iso_iName = 0 !--- Isotope name index in isotopes(iso_iGroup)%trac(:)
66	INTEGER :: iso_iZone = 0 !--- Isotope zone index in isotopes(iso_iGroup)%zone(:)
67	INTEGER :: iso_iPhase = 0 !--- Isotope phase index in isotopes(iso_iGroup)%phase
68	TYPE(keys_type) :: keys !--- <key>=<val> pairs vector
69	END TYPE trac_type
70	!------------------------------------------------------------------------------------------------------------------------------
71	TYPE :: isot_type !=== TYPE FOR AN ISOTOPES FAMILY DESCENDING ON TRACER "parent"
72	CHARACTER(LEN=maxlen) :: parent !--- Isotopes family name (parent tracer name ; ex: H2O)
73	LOGICAL :: check=.FALSE. !--- Triggering of the checking routines
74	TYPE(keys_type), ALLOCATABLE :: keys(:) !--- Isotopes keys/values pairs list (length: niso)
75	CHARACTER(LEN=maxlen), ALLOCATABLE :: trac(:) !--- Isotopes + tagging tracers list (length: ntiso)
76	CHARACTER(LEN=maxlen), ALLOCATABLE :: zone(:) !--- Geographic tagging zones names list (length: nzone)
77	CHARACTER(LEN=maxlen) :: phase = 'g' !--- Phases list: [g][l][s] (length: nphas)
78	INTEGER :: niso = 0 !--- Number of isotopes, excluding tagging tracers
79	INTEGER :: nzone = 0 !--- Number of geographic tagging zones
80	INTEGER :: ntiso = 0 !--- Number of isotopes, including tagging tracers
81	INTEGER :: nphas = 0 !--- Number phases
82	INTEGER, ALLOCATABLE :: iqIsoPha(:,:) !--- Idx in "tracers(1:nqtot)" = f(name(1:ntiso)),phas)
83	!--- "iqIsoPha" former name: "iqiso"
84	INTEGER, ALLOCATABLE :: itZonIso(:,:) !--- Idx in "trac(1:ntiso)" = f(zone, name(1:niso))
85	!--- "itZonIso" former name: "index_trac"
86	END TYPE isot_type
87	!------------------------------------------------------------------------------------------------------------------------------
88	TYPE :: dataBase_type !=== TYPE FOR TRACERS SECTION
89	CHARACTER(LEN=maxlen) :: name !--- Section name
90	TYPE(trac_type), ALLOCATABLE :: trac(:) !--- Tracers descriptors
91	END TYPE dataBase_type
92	!------------------------------------------------------------------------------------------------------------------------------
93	INTERFACE getKey
94	MODULE PROCEDURE getKeyByName_s1, getKeyByName_s1m, getKeyByName_sm, getKey_sm, &
95	getKeyByName_i1, getKeyByName_i1m, getKeyByName_im, getKey_im, &
96	getKeyByName_r1, getKeyByName_r1m, getKeyByName_rm, getKey_rm, &
97	getKeyByName_l1, getKeyByName_l1m, getKeyByName_lm, getKey_lm
98	END INTERFACE getKey
99	!------------------------------------------------------------------------------------------------------------------------------
100	INTERFACE isoSelect; MODULE PROCEDURE isoSelectByIndex, isoSelectByName; END INTERFACE isoSelect
101	INTERFACE old2newH2O; MODULE PROCEDURE old2newH2O_1, old2newH2O_m; END INTERFACE old2newH2O
102	INTERFACE new2oldH2O; MODULE PROCEDURE new2oldH2O_1, new2oldH2O_m; END INTERFACE new2oldH2O
103	INTERFACE fGetKey; MODULE PROCEDURE fgetKeyIdx_s1, fgetKeyNam_s1; END INTERFACE fGetKey
104	INTERFACE tracersSubset; MODULE PROCEDURE trSubset_Indx, trSubset_Name, trSubset_gen0Name; END INTERFACE tracersSubset
105	INTERFACE idxAncestor; MODULE PROCEDURE idxAncestor_1, idxAncestor_m, idxAncestor_mt; END INTERFACE idxAncestor
106	INTERFACE ancestor; MODULE PROCEDURE ancestor_1, ancestor_m, ancestor_mt; END INTERFACE ancestor
107	INTERFACE addKey; MODULE PROCEDURE addKey_1; END INTERFACE addKey!, addKey_m, addKey_mm; END INTERFACE addKey
108	INTERFACE addPhase; MODULE PROCEDURE addPhase_s1, addPhase_sm, addPhase_i1, addPhase_im; END INTERFACE addPhase
109	!------------------------------------------------------------------------------------------------------------------------------
110
111	!=== MAIN DATABASE: files sections descriptors
112	TYPE(dataBase_type), SAVE, ALLOCATABLE, TARGET :: dBase(:)
113
114	!--- SOME PARAMETERS THAT ARE NOT LIKELY TO CHANGE OFTEN
115	CHARACTER(LEN=maxlen), SAVE :: tran0 = 'air' !--- Default transporting fluid
116	CHARACTER(LEN=maxlen), PARAMETER :: old_phases = 'vlir' !--- Old phases for water (no separator)
117	CHARACTER(LEN=maxlen), PARAMETER :: known_phases = 'glsr' !--- Known phases initials
118	INTEGER, PARAMETER :: nphases = LEN_TRIM(known_phases) !--- Number of phases
119	CHARACTER(LEN=maxlen), SAVE :: phases_names(nphases) & !--- Known phases names
120	= ['gaseous', 'liquid ', 'solid ', 'cloud ']
121	CHARACTER(LEN=1), SAVE :: phases_sep = '_' !--- Phase separator
122	LOGICAL, SAVE :: tracs_merge = .TRUE. !--- Merge/stack tracers lists
123	LOGICAL, SAVE :: lSortByGen = .TRUE. !--- Sort by growing generation
124	CHARACTER(LEN=maxlen), SAVE :: isoFile = 'isotopes_params.def'!--- Name of the isotopes parameters file
125
126	!--- CORRESPONDANCE BETWEEN OLD AND NEW WATER NAMES
127	CHARACTER(LEN=maxlen), SAVE :: oldH2OIso(5) = ['eau', 'HDO', 'O18', 'O17', 'HTO' ]
128	CHARACTER(LEN=maxlen), SAVE :: newH2OIso(5) = ['H2[16]O', 'H[2]HO ', 'H2[18]O', 'H2[17]O', 'H[3]HO ']
129
130	!--- CORRESPONDANCE BETWEEN OLD AND NEW HNO3 RELATED SPECIES NAMES
131	CHARACTER(LEN=maxlen), SAVE :: oldHNO3(2) = ['HNO3_g ', 'HNO3 ']
132	CHARACTER(LEN=maxlen), SAVE :: newHNO3(2) = ['HNO3 ', 'HNO3tot']
133
134	!=== TRACERS AND ISOTOPES DESCRIPTORS, USED BY getKey
135	TYPE(trac_type), ALLOCATABLE, TARGET, SAVE :: tracers(:)
136	TYPE(isot_type), ALLOCATABLE, TARGET, SAVE :: isotopes(:)
137
138	!=== ALIASES OF VARIABLES FROM SELECTED ISOTOPES FAMILY EMBEDDED IN "isotope" (isotopes(ixIso))
139	TYPE(isot_type), SAVE, POINTER :: isotope !--- CURRENTLY SELECTED ISOTOPES FAMILY DESCRIPTOR
140	INTEGER, SAVE :: ixIso, iH2O !--- Index of the selected isotopes family and H2O family
141	INTEGER, SAVE :: nbIso !--- Number of isotopes classes
142	LOGICAL, SAVE :: isoCheck !--- Flag to trigger the checking routines
143	TYPE(keys_type), SAVE, POINTER :: isoKeys(:) !--- ONE SET OF KEYS FOR EACH ISOTOPE (LISTED IN isoName)
144	CHARACTER(LEN=maxlen), SAVE, POINTER :: isoName(:), & !--- ISOTOPES NAMES FOR THE CURRENTLY SELECTED FAMILY
145	isoZone(:), & !--- TAGGING ZONES FOR THE CURRENTLY SELECTED FAMILY
146	isoPhas !--- USED PHASES FOR THE CURRENTLY SELECTED FAMILY
147	INTEGER, SAVE :: niso, nzone, & !--- NUMBER OF ISOTOPES, TAGGING ZONES AND PHASES
148	nphas, ntiso !--- NUMBER OF PHASES AND ISOTOPES + ISOTOPIC TAGGING TRACERS
149	INTEGER, SAVE, POINTER ::itZonIso(:,:), & !--- INDEX IN "isoTrac" AS f(tagging zone idx, isotope idx)
150	iqIsoPha(:,:) !--- INDEX IN "qx" AS f(isotopic tracer idx, phase idx)
151
152	INTEGER, PARAMETER :: maxTableWidth = 192 !--- Maximum width of a table displayed with "dispTable"
153	CHARACTER(LEN=maxlen) :: modname
154
155	CONTAINS
156
157	!==============================================================================================================================
158	!==============================================================================================================================
159	!=== READ ONE OR SEVERAL TRACER FILES AND FILL A "tr" TRACERS DESCRIPTOR DERIVED TYPE.
160	!=== THE RETURNED VALUE fType DEPENDS ON WHAT IS FOUND:
161	!=== 0: NO ADEQUATE FILE FOUND ; DEFAULT VALUES MUST BE USED
162	!=== 1: AN "OLD STYLE" TRACERS FILE "traceur.def":
163	!=== First line: <nb tracers> Other lines: <hadv> <vadv> <tracer name> [<parent name>]
164	!=== 2: A "NEW STYLE" TRACERS FILE "tracer.def" WITH SEVERAL SECTIONS.
165	!=== 3: SEVERAL " " TRACERS FILES "tracer_<component>.def" WITH A SINGLE SECTION IN EACH.
166	!=== REMARKS:
167	!=== * EACH SECTION BEGINS WITH A "&<section name> LINE
168	!=== * DEFAULT VALUES FOR ALL THE SECTIONS OF THE FILE ARE DEFINED IN THE SPECIAL SECTION "&default"
169	!=== * EACH SECTION LINE HAS THE STRUCTURE: <name(s)> <key1>=<value1> <key2>=<value2> ...
170	!=== * SO FAR, THE DEFINED KEYS ARE: parent, phases, hadv, vadv, type
171	!=== * <name> AND <parent> CAN BE LISTS OF COMA-SEPARATED TRACERS ; THE ROUTINE EXPAND THESE FACTORIZATIONS.
172	!=== FUNCTION RETURN VALUE "lerr" IS FALSE IN CASE SOMETHING WENT WRONG.
173	!=== ABOUT THE KEYS:
174	! * The "keys" component (of type keys_type) is in principle enough to store everything we could need.
175	! But some variables are stored as direct-access keys to make the code more readable and because they are used often.
176	! * Most of the direct-access keys are set in this module, but some are not (longName, iadv, isAdvected for now).
177	! * Some of the direct-access keys must be updated (using the routine "setDirectKeys") is a subset of "tracers(:)"
178	! is extracted: the indexes are no longer valid for a subset (examples: iqParent, iqDescen).
179	! * If you need to convert a %key/%val pair into a direct-access key, add the corresponding line in "setDirectKeys".
180	!==============================================================================================================================
181	LOGICAL FUNCTION readTracersFiles(type_trac, fTyp, lRepr) RESULT(lerr)
182	!------------------------------------------------------------------------------------------------------------------------------
183	CHARACTER(LEN=*), INTENT(IN) :: type_trac !--- List of components used
184	INTEGER, OPTIONAL, INTENT(OUT) :: fTyp !--- Type of input file found
185	LOGICAL, OPTIONAL, INTENT(IN) :: lRepr !--- Activate the HNNO3 exceptions for REPROBUS
186	CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:), sections(:), trac_files(:)
187	CHARACTER(LEN=maxlen) :: str, fname, mesg, tname, pname, cname
188	INTEGER :: nsec, ierr, it, ntrac, ns, ip, ix, fType
189	LOGICAL, ALLOCATABLE :: ll(:), lGen3(:)
190	LOGICAL :: lRep
191	TYPE(keys_type), POINTER :: k
192	!------------------------------------------------------------------------------------------------------------------------------
193	lerr = .FALSE.
194	modname = 'readTracersFiles'
195	IF(.NOT.ALLOCATED(dBase)) ALLOCATE(dBase(0))
196	lRep=0; IF(PRESENT(lRepr)) lRep = lRepr
197
198	!--- Required sections + corresponding files names (new style single section case) for tests
199	IF(test(testTracersFiles(modname, type_trac, fType, .TRUE., trac_files, sections), lerr)) RETURN
200	IF(PRESENT(fTyp)) fTyp = fType
201	nsec = SIZE(sections)
202
203	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
204	SELECT CASE(fType) !--- Set %name, %genOName, %parent, %type, %phase, %component, %iGeneration, %keys
205	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
206	CASE(1) !=== OLD FORMAT "traceur.def"
207	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
208	!--- OPEN THE "traceur.def" FILE
209	OPEN(90, FILE="traceur.def", FORM='formatted', STATUS='old', IOSTAT=ierr)
210
211	!--- GET THE TRACERS NUMBER
212	READ(90,'(i3)',IOSTAT=ierr)ntrac !--- Number of lines/tracers
213	IF(test(fmsg('Invalid format for "'//TRIM(fname)//'"', modname, ierr /= 0), lerr)) RETURN
214
215	!--- READ THE REMAINING LINES: <hadv> <vadv> <tracer> [<transporting fluid>]
216	IF(ALLOCATED(tracers)) DEALLOCATE(tracers)
217	ALLOCATE(tracers(ntrac))
218	DO it=1,ntrac !=== READ RAW DATA: loop on the line/tracer number
219	READ(90,'(a)',IOSTAT=ierr) str
220	IF(test(fmsg('Invalid format for "' //TRIM(fname)//'"', modname, ierr>0), lerr)) RETURN
221	IF(test(fmsg('Not enough lines in "'//TRIM(fname)//'"', modname, ierr<0), lerr)) RETURN
222	ll = strParse(str, ' ', s, n=ns)
223	CALL msg('This file is for air tracers only', modname, ns == 3 .AND. it == 1)
224	CALL msg('This files specifies the transporting fluid', modname, ns == 4 .AND. it == 1)
225	k => tracers(it)%keys
226
227	!=== NAME OF THE TRACER
228	tname = old2newH2O(s(3), ip)
229	ix = strIdx(oldHNO3, s(3))
230	IF(ix /= 0 .AND. lRep) tname = newHNO3(ix) !--- Exception for HNO3 (REPROBUS ONLY)
231	tracers(it)%name = tname !--- Set %name
232	CALL addKey_1('name', tname, k) !--- Set the name of the tracer
233	tracers(it)%keys%name = tname !--- Copy tracers names in keys components
234
235	!=== NAME OF THE COMPONENT
236	cname = type_trac !--- Name of the model component
237	IF(ANY([(addPhase('H2O', ip), ip = 1, nphases)] == tname)) cname = 'lmdz'
238	tracers(it)%component = cname !--- Set %component
239	CALL addKey_1('component', cname, k) !--- Set the name of the model component
240
241	!=== NAME OF THE PARENT
242	pname = tran0 !--- Default name: default transporting fluid (air)
243	IF(ns == 4) THEN
244	pname = old2newH2O(s(4))
245	ix = strIdx(oldHNO3, s(4))
246	IF(ix /= 0 .AND. lRep) pname = newHNO3(ix) !--- Exception for HNO3 (REPROBUS ONLY)
247	END IF
248	tracers(it)%parent = pname !--- Set %parent
249	CALL addKey_1('parent', pname, k)
250
251	!=== PHASE AND ADVECTION SCHEMES NUMBERS
252	tracers(it)%phase = known_phases(ip:ip) !--- Set %phase: tracer phase (default: "g"azeous)
253	CALL addKey_1('phase', known_phases(ip:ip), k) !--- Set the phase of the tracer (default: "g"azeous)
254	CALL addKey_1('hadv', s(1), k) !--- Set the horizontal advection schemes number
255	CALL addKey_1('vadv', s(2), k) !--- Set the vertical advection schemes number
256	END DO
257	CLOSE(90)
258	IF(test(setGeneration(tracers), lerr)) RETURN !--- Set %iGeneration and %gen0Name
259	WHERE(tracers%iGeneration == 2) tracers(:)%type = 'tag' !--- Set %type: 'tracer' or 'tag'
260	DO it=1,ntrac
261	CALL addKey_1('type', tracers(it)%type, tracers(it)%keys) !--- Set the type of tracer
262	END DO
263	IF(test(checkTracers(tracers, fname, fname), lerr)) RETURN !--- Detect orphans and check phases
264	IF(test(checkUnique (tracers, fname, fname), lerr)) RETURN !--- Detect repeated tracers
265	CALL sortTracers (tracers) !--- Sort the tracers
266	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
267	CASE(2); IF(test(feedDBase(["tracer.def"], [type_trac], modname), lerr)) RETURN !=== SINGLE FILE, MULTIPLE SECTIONS
268	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
269	CASE(3); IF(test(feedDBase( trac_files , sections, modname), lerr)) RETURN !=== MULTIPLE FILES, SINGLE SECTION
270	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
271	END SELECT
272	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
273	IF(ALL([2,3] /= fType)) RETURN
274
275	IF(nsec == 1) THEN;
276	tracers = dBase(1)%trac
277	ELSE IF(tracs_merge) THEN
278	CALL msg('The multiple required sections will be MERGED.', modname)
279	IF(test(mergeTracers(dBase, tracers), lerr)) RETURN
280	ELSE
281	CALL msg('The multiple required sections will be CUMULATED.', modname)
282	IF(test(cumulTracers(dBase, tracers), lerr)) RETURN
283	END IF
284	CALL setDirectKeys(tracers) !--- Set %iqParent, %iqDescen, %nqDescen, %nqChildren
285	END FUNCTION readTracersFiles
286	!==============================================================================================================================
287
288
289	!==============================================================================================================================
290	LOGICAL FUNCTION testTracersFiles(modname, type_trac, fType, lDisp, tracf, sects) RESULT(lerr)
291	CHARACTER(LEN=*), INTENT(IN) :: modname, type_trac
292	INTEGER, INTENT(OUT) :: fType
293	LOGICAL, INTENT(IN) :: lDisp
294	CHARACTER(LEN=maxlen), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: tracf(:), sects(:)
295	CHARACTER(LEN=maxlen), ALLOCATABLE :: trac_files(:), sections(:)
296	LOGICAL, ALLOCATABLE :: ll(:)
297	INTEGER :: is, nsec
298
299	!--- PARSE "type_trac" LIST AND DETERMINE THE TRACERS FILES NAMES (FOR CASE 3: MULTIPLE FILES, SINNGLE SECTION PER FILE)
300	IF(test(strParse(type_trac, '\|', sections, n=nsec), lerr)) RETURN !--- Parse "type_trac" list
301	IF(PRESENT(sects)) sects = sections
302	ALLOCATE(trac_files(nsec)); DO is=1, nsec; trac_files(is) = 'tracer_'//TRIM(sections(is))//'.def'; END DO
303	IF(PRESENT(tracf)) tracf = trac_files
304
305	nsec = SIZE(trac_files, DIM=1)
306	ll = .NOT.testFile(trac_files)
307	fType = 0
308	IF(.NOT.testFile('traceur.def') .AND. nsec==1) fType = 1 !--- OLD STYLE FILE
309	IF(.NOT.testFile('tracer.def')) fType = 2 !--- NEW STYLE ; SINGLE FILE, SEVERAL SECTIONS
310	IF(ALL(ll)) fType = 3 !--- NEW STYLE ; SEVERAL FILES, SINGLE SECTION USED
311	IF(.NOT.test(lDisp, lerr)) RETURN !--- NO CHECKING/DISPLAY NEEDED: JUST GET type_trac,fType
312	IF(ANY(ll) .AND. fType/=3) THEN !--- MISSING FILES
313	IF(test(checkList(trac_files, .NOT.ll, 'Failed reading tracers description', 'files', 'missing'), lerr)) RETURN
314	END IF
315
316	!--- CHECK WHETHER type_trac AND FILE TYPE ARE COMPATIBLE
317	IF(test(fmsg('No multiple sections for the old format "traceur.def"', ll = nsec>1 .AND. fType==1), lerr)) RETURN
318
319	!--- TELLS WHAT WAS IS ABOUT TO BE USED
320	CALL msg('Trying to read old-style tracers description file "traceur.def"', modname, fType==1)
321	CALL msg('Trying to read the new style multi-sections tracers description file "tracer.def"', modname, fType==2)
322	CALL msg('Trying to read the new style single section tracers description files "tracer_*.def"', modname, fType==3)
323	END FUNCTION testTracersFiles
324	!==============================================================================================================================
325
326	!==============================================================================================================================
327	LOGICAL FUNCTION feedDBase(fnames, snames, modname) RESULT(lerr)
328	! Purpose: Read the sections "snames(is)" (pipe-separated list) from each "fnames(is)"
329	! file and create the corresponding tracers set descriptors in the database "dBase":
330	! * dBase(id)%name : section name
331	! * dBase(id)%trac(:)%name : tracers names
332	! * dBase(id)%trac(it)%keys%key(:): names of keys associated to tracer dBase(id)%trac(it)%name
333	! * dBase(id)%trac(it)%keys%val(:): values of keys associated to tracer dBase(id)%trac(it)%name
334	!------------------------------------------------------------------------------------------------------------------------------
335	CHARACTER(LEN=*), INTENT(IN) :: fnames(:) !--- Files names
336	CHARACTER(LEN=*), INTENT(IN) :: snames(:) !--- Pipe-deparated list of sections (one list each file)
337	CHARACTER(LEN=*), INTENT(IN) :: modname !--- Calling routine name
338	INTEGER, ALLOCATABLE :: ndb(:) !--- Number of sections for each file
339	INTEGER, ALLOCATABLE :: ixf(:) !--- File index for each section of the expanded list
340	LOGICAL, ALLOCATABLE :: lTg(:) !--- Tagging tracers mask
341	CHARACTER(LEN=maxlen) :: fnm, snm
342	INTEGER :: idb, i
343	LOGICAL :: ll
344	!------------------------------------------------------------------------------------------------------------------------------
345	!=== READ THE REQUIRED SECTIONS
346	ll = strCount(snames, '\|', ndb) !--- Number of sections for each file
347	ALLOCATE(ixf(SUM(ndb)))
348	DO i=1, SIZE(fnames) !--- Set %name, %keys
349	IF(test(readSections(fnames(i), snames(i), 'default'), lerr)) RETURN
350	ixf(1+SUM(ndb(1:i-1)):SUM(ndb(1:i))) = i !--- File index for each section of the expanded list
351	END DO
352	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
353	DO idb=1,SIZE(dBase) !--- LOOP ON THE LOADED SECTIONS
354	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
355	fnm = fnames(ixf(idb)); snm = dBase(idb)%name !--- FILE AND SECTION NAMES
356	lerr = ANY([(dispTraSection('RAW CONTENT OF SECTION "'//TRIM(snm)//'"', snm, modname), idb=1, SIZE(dBase))])
357	IF(test(expandSection(dBase(idb)%trac, snm, fnm), lerr)) RETURN !--- EXPAND NAMES ; set %parent, %type, %component
358	IF(test(setGeneration(dBase(idb)%trac), lerr)) RETURN !--- set %iGeneration, %genOName
359	IF(test(checkTracers (dBase(idb)%trac, snm, fnm), lerr)) RETURN !--- CHECK ORPHANS AND PHASES
360	IF(test(checkUnique (dBase(idb)%trac, snm, fnm), lerr)) RETURN !--- CHECK TRACERS UNIQUENESS
361	CALL expandPhases (dBase(idb)%trac) !--- EXPAND PHASES ; set %phase
362	CALL sortTracers (dBase(idb)%trac) !--- SORT TRACERS
363	lerr = ANY([(dispTraSection('EXPANDED CONTENT OF SECTION "'//TRIM(snm)//'"', snm, modname), idb=1, SIZE(dBase))])
364	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
365	END DO
366	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
367	END FUNCTION feedDBase
368	!------------------------------------------------------------------------------------------------------------------------------
369
370	!------------------------------------------------------------------------------------------------------------------------------
371	LOGICAL FUNCTION readSections(fnam,snam,defName) RESULT(lerr)
372	!------------------------------------------------------------------------------------------------------------------------------
373	CHARACTER(LEN=*), INTENT(IN) :: fnam !--- File name
374	CHARACTER(LEN=*), INTENT(IN) :: snam !--- Pipe-separated sections list
375	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: defName !--- Special section (default values) name
376	!------------------------------------------------------------------------------------------------------------------------------
377	TYPE(dataBase_type), ALLOCATABLE :: tdb(:)
378	CHARACTER(LEN=maxlen), ALLOCATABLE :: sec(:)
379	INTEGER, ALLOCATABLE :: ix(:)
380	INTEGER :: n0, idb, ndb, i, j
381	LOGICAL :: ll
382	!------------------------------------------------------------------------------------------------------------------------------
383	n0 = SIZE(dBase) + 1 !--- Index for next entry in the database
384	CALL readSections_all() !--- Read all the sections of file "fnam"
385	ndb= SIZE(dBase) !--- Current number of sections in the database
386	IF(PRESENT(defName)) THEN !--- Add default values to all the tracers
387	DO idb=n0,ndb; CALL addDefault(dBase(idb)%trac, defName); END DO !--- and remove the virtual tracer "defName"
388	END IF
389	ll = strParse(snam, '\|', keys = sec) !--- Requested sections names
390	ix = strIdx(dBase(:)%name, sec(:)) !--- Indexes of requested sections in database
391	IF(test(checkList(sec, ix == 0, 'In file "'//TRIM(fnam)//'"','section(s)', 'missing'), lerr)) RETURN
392	tdb = dBase(:); dBase = [tdb(1:n0-1),tdb(PACK(ix, MASK=ix/=0))] !--- Keep requested sections only
393
394	CONTAINS
395
396	!------------------------------------------------------------------------------------------------------------------------------
397	SUBROUTINE readSections_all()
398	!------------------------------------------------------------------------------------------------------------------------------
399	CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:), v(:)
400	TYPE(trac_type), ALLOCATABLE :: tt(:)
401	TYPE(trac_type) :: tmp
402	CHARACTER(LEN=1024) :: str, str2
403	CHARACTER(LEN=maxlen) :: secn
404	INTEGER :: ierr, n
405	!------------------------------------------------------------------------------------------------------------------------------
406	IF(.NOT.ALLOCATED(dBase)) ALLOCATE(dBase(0))
407	OPEN(90, FILE=fnam, FORM='formatted', STATUS='old')
408	DO; str=''
409	DO
410	READ(90,'(a)', IOSTAT=ierr)str2 !--- Read a full line
411	str=TRIM(str)//' '//TRIM(str2) !--- Append "str" with the current line
412	n=LEN_TRIM(str); IF(n == 0) EXIT !--- Empty line (probably end of file)
413	IF(IACHAR(str(n:n)) /= 92) EXIT !--- No "\" continuing line symbol found => end of line
414	str = str(1:n-1) !--- Remove the "\" continuing line symbol
415	END DO
416	str = ADJUSTL(str) !--- Remove the front space
417	IF(ierr /= 0 ) EXIT !--- Finished: error or end of file
418	IF(str(1:1)=='#') CYCLE !--- Skip comments lines
419	CALL removeComment(str) !--- Skip comments at the end of a line
420	IF(str == '') CYCLE !--- Skip empty line (probably at the end of the file)
421	IF(str(1:1)=='&') THEN !=== SECTION HEADER LINE
422	ndb = SIZE(dBase) !--- Number of sections so far
423	secn = str(2:LEN_TRIM(str))//' ' !--- Current section name
424	IF(ANY(dBase(:)%name == secn)) CYCLE !--- Already known section
425	IF(secn(1:7) == 'version') CYCLE !--- Skip the "version" special section
426	ndb = ndb + 1 !--- Extend database
427	ALLOCATE(tdb(ndb))
428	tdb(1:ndb-1) = dBase
429	tdb(ndb)%name = secn
430	ALLOCATE(tdb(ndb)%trac(0))
431	CALL MOVE_ALLOC(FROM=tdb, TO=dBase)
432	ELSE !=== TRACER LINE
433	ll = strParse(str,' ', keys = s, vals = v, n = n) !--- Parse <key>=<val> pairs
434	tt = dBase(ndb)%trac(:)
435	tmp%name = s(1); tmp%keys = keys_type(s(1), s(2:n), v(2:n)) !--- Set %name and %keys
436	dBase(ndb)%trac = [tt(:), tmp]
437	DEALLOCATE(tt)
438	! dBase(ndb)%trac = [dBase(ndb)%trac(:), tra(name=s(1), keys=keys_type(s(1), s(2:n), v(2:n)))]
439	END IF
440	END DO
441	CLOSE(90)
442
443	END SUBROUTINE readSections_all
444	!------------------------------------------------------------------------------------------------------------------------------
445
446	END FUNCTION readSections
447	!==============================================================================================================================
448
449
450	!==============================================================================================================================
451	SUBROUTINE addDefault(t, defName)
452	!------------------------------------------------------------------------------------------------------------------------------
453	! Purpose: Add the keys from virtual tracer named "defName" (if any) and remove this virtual tracer.
454	!------------------------------------------------------------------------------------------------------------------------------
455	TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:)
456	CHARACTER(LEN=*), INTENT(IN) :: defName
457	INTEGER :: jd, it, k
458	TYPE(keys_type), POINTER :: ky
459	TYPE(trac_type), ALLOCATABLE :: tt(:)
460	jd = strIdx(t(:)%name, defName)
461	IF(jd == 0) RETURN
462	ky => t(jd)%keys
463	DO k = 1, SIZE(ky%key) !--- Loop on the keys of the tracer named "defName"
464	! CALL addKey_m(ky%key(k), ky%val(k), t(:)%keys, .FALSE.) !--- Add key to all the tracers (no overwriting)
465	DO it = 1, SIZE(t); CALL addKey_1(ky%key(k), ky%val(k), t(it)%keys, .FALSE.); END DO
466	END DO
467	tt = [t(1:jd-1),t(jd+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t) !--- Remove the virtual tracer named "defName"
468	END SUBROUTINE addDefault
469	!==============================================================================================================================
470
471	!==============================================================================================================================
472	SUBROUTINE subDefault(t, defName, lSubLocal)
473	!------------------------------------------------------------------------------------------------------------------------------
474	! Purpose: Substitute the keys from virtual tracer named "defName" (if any) and remove this virtual tracer.
475	! Substitute the keys locally (for the current tracer) if the flag "lSubLocal" is .TRUE.
476	!------------------------------------------------------------------------------------------------------------------------------
477	TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:)
478	CHARACTER(LEN=*), INTENT(IN) :: defName
479	LOGICAL, INTENT(IN) :: lSubLocal
480	INTEGER :: i0, it, ik
481	TYPE(keys_type), POINTER :: k0, ky
482	TYPE(trac_type), ALLOCATABLE :: tt(:)
483	i0 = strIdx(t(:)%name, defName)
484	IF(i0 == 0) RETURN
485	k0 => t(i0)%keys
486	DO it = 1, SIZE(t); IF(it == i0) CYCLE !--- Loop on the tracers
487	ky => t(it)%keys
488
489	!--- Substitute in the values of <key>=<val> pairs the keys defined in the virtual tracer "defName"
490	DO ik = 1, SIZE(k0%key); CALL strReplace(ky%val, k0%key(ik), k0%val(ik), .TRUE.); END DO
491
492	IF(.NOT.lSubLocal) CYCLE
493	!--- Substitute in the values of <key>=<val> pairs the keys defined locally (in the current tracer)
494	DO ik = 1, SIZE(ky%key); CALL strReplace(ky%val, ky%key(ik), ky%val(ik), .TRUE.); END DO
495	END DO
496	tt = [t(1:i0-1),t(i0+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t) !--- Remove the virtual tracer named "defName"
497
498	END SUBROUTINE subDefault
499	!==============================================================================================================================
500
501
502	!==============================================================================================================================
503	LOGICAL FUNCTION expandSection(tr, sname, fname) RESULT(lerr)
504	!------------------------------------------------------------------------------------------------------------------------------
505	! Purpose: Expand tracers and parents lists in the tracers descriptor "tra".
506	! Note: * The following keys are expanded, so are accessible explicitely using "%" operator: "parent" "type".
507	! * Default values are provided for these keys because they are necessary.
508	!------------------------------------------------------------------------------------------------------------------------------
509	TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector
510	CHARACTER(LEN=*), INTENT(IN) :: sname
511	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname
512	TYPE(trac_type), ALLOCATABLE :: ttr(:)
513	CHARACTER(LEN=maxlen), ALLOCATABLE :: ta(:), pa(:)
514	CHARACTER(LEN=maxlen) :: msg1, modname, tname, cname , pname
515	INTEGER :: it, nt, iq, nq, jq, itr, ntr, ipr, npr, i
516	LOGICAL :: ll
517	modname = 'expandSection'
518	lerr = .FALSE.
519	nt = SIZE(tr)
520	nq = 0
521	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
522	DO it = 1, nt !=== GET TRACERS NB AFTER EXPANSION + NEEDED KEYS (name, parent, type)
523	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
524	!--- Extract useful keys: parent name, type, component name
525	tr(it)%parent = fgetKey(it, 'parent', tr(:)%keys, tran0 )
526	tr(it)%type = fgetKey(it, 'type' , tr(:)%keys, 'tracer')
527	tr(it)%component = sname
528	! CALL addKey_m('component', sname, tr(:)%keys)
529	DO iq=1,SIZE(tr); CALL addKey_1('component', sname, tr(iq)%keys); END DO
530
531	!--- Determine the number of tracers and parents ; coherence checking
532	ll = strCount(tr(it)%name, ',', ntr)
533	ll = strCount(tr(it)%parent, ',', npr)
534
535	!--- Tagging tracers only can have multiple parents
536	IF(test(npr/=1 .AND. TRIM(tr(it)%type)/='tag', lerr)) THEN
537	msg1 = 'Check section "'//TRIM(sname)//'"'
538	IF(PRESENT(fname)) msg1=TRIM(msg1)//' in file "'//TRIM(fname)//'"'
539	CALL msg(TRIM(msg1)//': "'//TRIM(tr(it)%name)//'" has several parents but is not a tag', modname); RETURN
540	END IF
541	nq = nq + ntr*npr
542	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
543	END DO
544	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
545
546	ALLOCATE(ttr(nq))
547	iq = 1
548	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
549	DO it = 1, nt !=== EXPAND TRACERS AND PARENTS NAMES LISTS
550	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
551	ll = strParse(tr(it)%name, ',', ta, n=ntr) !--- Number of tracers
552	ll = strParse(tr(it)%parent, ',', pa, n=npr) !--- Number of parents
553	DO ipr=1,npr !--- Loop on parents list elts
554	DO itr=1,ntr !--- Loop on tracers list elts
555	ttr(iq)%keys%key = tr(it)%keys%key
556	ttr(iq)%keys%val = tr(it)%keys%val
557	ttr(iq)%keys%name = ta(itr)
558	ttr(iq)%name = TRIM(ta(itr)); CALL addKey_1('name', ta(itr), ttr(iq)%keys)
559	ttr(iq)%parent = TRIM(pa(ipr)); CALL addKey_1('parent', pa(ipr), ttr(iq)%keys)
560	ttr(iq)%type = tr(it)%type; CALL addKey_1('type', tr(it)%type, ttr(iq)%keys)
561	ttr(iq)%component = tr(it)%component; CALL addKey_1('component', tr(it)%component, ttr(iq)%keys)
562	iq = iq+1
563	END DO
564	END DO
565	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
566	END DO
567	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
568	DEALLOCATE(ta,pa)
569	CALL MOVE_ALLOC(FROM=ttr, TO=tr)
570
571	END FUNCTION expandSection
572	!==============================================================================================================================
573
574
575	!==============================================================================================================================
576	LOGICAL FUNCTION setGeneration(tr) RESULT(lerr)
577	!------------------------------------------------------------------------------------------------------------------------------
578	! Purpose: Determine, for each tracer of "tr(:)":
579	! * %iGeneration: the generation number
580	! * %gen0Name: the generation 0 ancestor name
581	! Check also for orphan tracers (tracers not descending on "tran0").
582	!------------------------------------------------------------------------------------------------------------------------------
583	TYPE(trac_type), INTENT(INOUT) :: tr(:) !--- Tracer derived type vector
584	INTEGER :: iq, jq, ig
585	CHARACTER(LEN=maxlen), ALLOCATABLE :: parent(:)
586	!------------------------------------------------------------------------------------------------------------------------------
587	CHARACTER(LEN=maxlen) :: modname
588	modname = 'setGeneration'
589	IF(test(fmsg('missing "parent" attribute', modname, getKey('parent', parent, ky=tr(:)%keys)), lerr)) RETURN
590	DO iq = 1, SIZE(tr)
591	jq = iq; ig = 0
592	DO WHILE(parent(jq) /= tran0)
593	jq = strIdx(tr(:)%name, parent(iq))
594	IF(test(fmsg('Orphan tracer "'//TRIM(tr(iq)%name)//'"', modname, jq == 0), lerr)) RETURN
595	ig = ig + 1
596	END DO
597	tr(iq)%gen0Name = tr(jq)%name; CALL addKey_1('gen0Name', tr(iq)%gen0Name, tr(iq)%keys)
598	tr(iq)%iGeneration = ig; CALL addKey_1('iGeneration', TRIM(int2str(ig)), tr(iq)%keys)
599	END DO
600	END FUNCTION setGeneration
601	!==============================================================================================================================
602
603
604	!==============================================================================================================================
605	LOGICAL FUNCTION checkTracers(tr, sname, fname) RESULT(lerr)
606	!------------------------------------------------------------------------------------------------------------------------------
607	! Purpose:
608	! * check for orphan tracers (without known parent)
609	! * check wether the phases are known or not ("g"aseous, "l"iquid or "s"olid so far)
610	!------------------------------------------------------------------------------------------------------------------------------
611	TYPE(trac_type), INTENT(IN) :: tr(:) !--- Tracer derived type vector
612	CHARACTER(LEN=*), INTENT(IN) :: sname !--- Section name
613	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- File name
614	CHARACTER(LEN=maxlen) :: mesg
615	CHARACTER(LEN=maxlen) :: bp(SIZE(tr, DIM=1)), pha !--- Bad phases list, phases of current tracer
616	CHARACTER(LEN=1) :: p
617	INTEGER :: ip, np, iq, nq
618	!------------------------------------------------------------------------------------------------------------------------------
619	nq = SIZE(tr,DIM=1) !--- Number of tracers lines
620	mesg = 'Check section "'//TRIM(sname)//'"'
621	IF(PRESENT(fname)) mesg=TRIM(mesg)//' in file "'//TRIM(fname)//'"'
622
623	!=== CHECK FOR ORPHAN TRACERS
624	IF(test(checkList(tr%name, tr%iGeneration==-1, mesg, 'tracers', 'orphan'), lerr)) RETURN
625
626	!=== CHECK PHASES
627	DO iq=1,nq; IF(tr(iq)%iGeneration/=0) CYCLE !--- Generation O only is checked
628	pha = fgetKey(iq, 'phases', tr(:)%keys, 'g') !--- Phases
629	np = LEN_TRIM(pha); bp(iq)=' '
630	DO ip=1,np; p = pha(ip:ip); IF(INDEX(known_phases,p)==0) bp(iq) = TRIM(bp(iq))//p; END DO
631	IF(TRIM(bp(iq)) /= '') bp(iq) = TRIM(tr(iq)%name)//': '//TRIM(bp(iq))
632	END DO
633	lerr = checkList(bp, tr%iGeneration==0 .AND. bp/='', mesg, 'tracers phases', 'unknown')
634	END FUNCTION checkTracers
635	!==============================================================================================================================
636
637
638	!==============================================================================================================================
639	LOGICAL FUNCTION checkUnique(tr, sname, fname) RESULT(lerr)
640	!------------------------------------------------------------------------------------------------------------------------------
641	! Purpose: Make sure that tracers are not repeated.
642	!------------------------------------------------------------------------------------------------------------------------------
643	TYPE(trac_type), INTENT(IN) :: tr(:) !--- Tracer derived type vector
644	CHARACTER(LEN=*), INTENT(IN) :: sname !--- Section name
645	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- File name
646	!------------------------------------------------------------------------------------------------------------------------------
647	INTEGER :: ip, np, iq, nq, k
648	LOGICAL, ALLOCATABLE :: ll(:)
649	CHARACTER(LEN=maxlen) :: mesg, tnam, tdup(SIZE(tr,DIM=1))
650	CHARACTER(LEN=1) :: p
651	!------------------------------------------------------------------------------------------------------------------------------
652	mesg = 'Check section "'//TRIM(sname)//'"'
653	IF(PRESENT(fname)) mesg=TRIM(mesg)//' in file "'//TRIM(fname)//'"'
654	nq=SIZE(tr,DIM=1); lerr=.FALSE. !--- Number of lines ; error flag
655	tdup(:) = ''
656	DO iq=1,nq; IF(tr(iq)%type == 'tag') CYCLE !--- Tags can be repeated
657	tnam = TRIM(tr(iq)%name)
658	ll = tr(:)%name==TRIM(tnam) !--- Mask for current tracer name
659	IF(COUNT(ll)==1 ) CYCLE !--- Tracer is not repeated
660	IF(tr(iq)%iGeneration>0) THEN
661	tdup(iq) = tnam !--- gen>0: MUST be unique
662	ELSE
663	DO ip=1,nphases; p=known_phases(ip:ip) !--- Loop on known phases
664	!--- Number of appearances of the current tracer with known phase "p"
665	np = COUNT( PACK( [(INDEX(fgetKey(k, 'phases', tr(:)%keys, 'g'),p), k=1, nq)] /=0 , MASK=ll ) )
666	IF(np <=1) CYCLE
667	tdup(iq) = TRIM(tdup(iq))//TRIM(phases_names(ip))
668	IF(ANY(tdup(1:iq-1) == tdup(iq))) tdup(iq)='' !--- Avoid repeating same messages
669	END DO
670	END IF
671	IF(tdup(iq) /= '') tdup(iq)=TRIM(tnam)//' in '//TRIM(tdup(iq))//' phase(s)'
672	END DO
673	lerr = checkList(tdup, tdup/='', mesg, 'tracers', 'duplicated')
674	END FUNCTION checkUnique
675	!==============================================================================================================================
676
677
678	!==============================================================================================================================
679	SUBROUTINE expandPhases(tr)
680	!------------------------------------------------------------------------------------------------------------------------------
681	! Purpose: Expand the phases in the tracers descriptor "tr". Phases are not repeated for a tracer, thanks to "checkUnique".
682	!------------------------------------------------------------------------------------------------------------------------------
683	TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector
684	!------------------------------------------------------------------------------------------------------------------------------
685	TYPE(trac_type), ALLOCATABLE :: ttr(:)
686	INTEGER, ALLOCATABLE :: i0(:)
687	CHARACTER(LEN=maxlen) :: nam, pha, tname
688	CHARACTER(LEN=maxlen), allocatable :: ph(:)
689	CHARACTER(LEN=1) :: p
690	INTEGER :: ip, np, iq, jq, nq, it, nt, nc, i, n
691	LOGICAL :: lTag, lExt
692	!------------------------------------------------------------------------------------------------------------------------------
693	nq = SIZE(tr, DIM=1)
694	nt = 0
695	DO iq = 1, nq !--- GET THE NUMBER OF TRACERS
696	IF(tr(iq)%iGeneration /= 0) CYCLE !--- Only deal with generation 0 tracers
697	nc = COUNT(tr(:)%gen0Name==tr(iq)%name .AND. tr%iGeneration/=0) !--- Number of children of tr(iq)
698	tr(iq)%phase = fgetKey(iq, 'phases', tr(:)%keys) !--- Phases list of tr(iq)
699	np = LEN_TRIM(tr(iq)%phase) !--- Number of phases of tr(iq)
700	nt = nt + (1+nc) * np !--- Number of tracers after expansion
701	END DO
702	ALLOCATE(ttr(nt)) !--- Version of "tr" after phases expansion
703	it = 1 !--- Current "ttr(:)" index
704	DO iq = 1, nq !--- Loop on "tr(:)" indexes
705	lTag = tr(iq)%type=='tag' !--- Current tracer is a tag
706	i0 = strFind(tr(:)%name, TRIM(tr(iq)%gen0Name), n) !--- Indexes of first generation ancestor copies
707	np = SUM([( LEN_TRIM(tr(i0(i))%phase),i=1,n )], 1) !--- Number of phases for current tracer tr(iq)
708	lExt = np>1 !--- Phase suffix only required if phases number is > 1
709	IF(lTag) lExt = lExt .AND. tr(iq)%iGeneration>0 !--- No phase suffix for generation 0 tags
710	DO i=1,n !=== LOOP ON GENERATION 0 ANCESTORS
711	jq = i0(i) !--- tr(jq): ith tracer with same gen 0 ancestor as tr(iq)
712	IF(tr(iq)%iGeneration==0) jq=iq !--- Generation 0: count the current tracer phases only
713	pha = tr(jq)%phase !--- Phases list for tr(jq)
714	DO ip = 1, LEN_TRIM(pha) !=== LOOP ON PHASES LISTS
715	p = pha(ip:ip)
716	tname = TRIM(tr(iq)%name); nam = tname !--- Tracer name (regular case)
717	IF(lTag) nam = TRIM(tr(iq)%parent) !--- Parent name (tagging case)
718	IF(lExt) nam = addPhase(nam, p ) !--- Phase extension needed
719	IF(lTag) nam = TRIM(nam)//'_'//TRIM(tname) !--- <parent>_<name> for tags
720	ttr(it) = tr(iq) !--- Same <key>=<val> pairs
721	ttr(it)%name = TRIM(nam) !--- Name with possibly phase suffix
722	ttr(it)%keys%name = TRIM(nam) !--- Name inside the keys decriptor
723	ttr(it)%phase = p !--- Single phase entry
724	CALL addKey_1('name', nam, ttr(it)%keys)
725	CALL addKey_1('phase', p, ttr(it)%keys)
726	IF(lExt .AND. tr(iq)%iGeneration>0) THEN
727	ttr(it)%parent = addPhase(tr(iq)%parent, p)
728	ttr(it)%gen0Name = addPhase(tr(iq)%gen0Name, p)
729	CALL addKey_1('parent', ttr(it)%parent, ttr(it)%keys)
730	CALL addKey_1('gen0Name', ttr(it)%gen0Name, ttr(it)%keys)
731	END IF
732	it = it+1
733	END DO
734	IF(tr(iq)%iGeneration==0) EXIT !--- Break phase loop for gen 0
735	END DO
736	END DO
737	CALL MOVE_ALLOC(FROM=ttr, TO=tr)
738	CALL delKey(['phases'],tr) !--- Remove few keys entries
739
740	END SUBROUTINE expandPhases
741	!==============================================================================================================================
742
743
744	!==============================================================================================================================
745	SUBROUTINE sortTracers(tr)
746	!------------------------------------------------------------------------------------------------------------------------------
747	! Purpose: Sort tracers:
748	! * Put water at the beginning of the vector, in the "known_phases" order.
749	! * lGrowGen == T: in ascending generations numbers.
750	! * lGrowGen == F: tracer + its children sorted by growing generation, one after the other.
751	! TO BE ADDED IF NECESSARY: HIGHER MOMENTS AT THE END
752	!------------------------------------------------------------------------------------------------------------------------------
753	TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector
754	!------------------------------------------------------------------------------------------------------------------------------
755	TYPE(trac_type), ALLOCATABLE :: tr2(:)
756	INTEGER, ALLOCATABLE :: iy(:), iz(:)
757	INTEGER :: ig, ng, iq, jq, ip, nq, n, ix(SIZE(tr)), k
758	INTEGER :: it
759	! tr2 is introduced in order to cope with a bug in gfortran 4.8.5 compiler
760	!------------------------------------------------------------------------------------------------------------------------------
761	nq = SIZE(tr)
762	DO ip = nphases, 1, -1
763	iq = strIdx(tr(:)%name, addPhase('H2O', ip))
764	IF(iq == 0) CYCLE
765	tr2 = tr(:)
766	tr = [tr2(iq), tr2(1:iq-1), tr2(iq+1:nq)]
767	END DO
768	IF(lSortByGen) THEN
769	iq = 1
770	ng = MAXVAL(tr(:)%iGeneration, MASK=.TRUE., DIM=1) !--- Number of generations
771	DO ig = 0, ng !--- Loop on generations
772	iy = PACK([(k, k=1, nq)], MASK=tr(:)%iGeneration==ig) !--- Generation ig tracers indexes
773	n = SIZE(iy)
774	ix(iq:iq+n-1) = iy !--- Stack growing generations idxs
775	iq = iq + n
776	END DO
777	ELSE
778	iq = 1
779	DO jq = 1, nq !--- Loop on generation 0 tracers
780	IF(tr(jq)%iGeneration /= 0) CYCLE !--- Skip generations /= 0
781	ix(iq) = jq !--- Generation 0 ancestor index first
782	iq = iq + 1 !--- Next "iq" for next generations tracers
783	iy = strFind(tr(:)%gen0Name, TRIM(tr(jq)%name)) !--- Indexes of "tr(jq)" children in "tr(:)"
784	ng = MAXVAL(tr(iy)%iGeneration, MASK=.TRUE., DIM=1) !--- Number of generations of the "tr(jq)" family
785	DO ig = 1, ng !--- Loop on generations of the "tr(jq)" family
786	iz = find(tr(iy)%iGeneration, ig, n) !--- Indexes of the tracers "tr(iy(:))" of generation "ig"
787	ix(iq:iq+n-1) = iy(iz) !--- Same indexes in "tr(:)"
788	iq = iq + n
789	END DO
790	END DO
791	END IF
792	tr = tr(ix) !--- Reorder the tracers
793	END SUBROUTINE sortTracers
794	!==============================================================================================================================
795
796
797	!==============================================================================================================================
798	LOGICAL FUNCTION mergeTracers(sections, tr) RESULT(lerr)
799	TYPE(dataBase_type), TARGET, INTENT(IN) :: sections(:)
800	TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: tr(:)
801	TYPE(trac_type), POINTER :: t1(:), t2(:)
802	INTEGER, ALLOCATABLE :: ixct(:), ixck(:)
803	INTEGER :: is, k1, k2, nk2, i1, i2, nt2
804	CHARACTER(LEN=maxlen) :: s1, v1, v2, tnam, knam, modname
805	modname = 'mergeTracers'
806	lerr = .FALSE.
807	t1 => sections(1)%trac(:) !--- Alias: first tracers section
808	tr = t1
809	!----------------------------------------------------------------------------------------------------------------------------
810	DO is=2,SIZE(sections) !=== SEVERAL SECTIONS: MERGE THEM
811	!----------------------------------------------------------------------------------------------------------------------------
812	t2 => sections(is)%trac(:) !--- Alias: current tracers section
813	nt2 = SIZE(t2(:), DIM=1) !--- Number of tracers in section
814	ixct = strIdx(t1(:)%name, t2(:)%name) !--- Indexes of common tracers
815	tr = [tr, PACK(t2, MASK= ixct==0)] !--- Append with new tracers
816	IF( ALL(ixct == 0) ) CYCLE !--- No common tracers => done
817	CALL msg('Tracers defined in previous sections and duplicated in "'//TRIM(sections(is)%name)//'":', modname)
818	CALL msg(t1(PACK(ixct, MASK = ixct/=0))%name, modname, nmax=128) !--- Display duplicates (the 128 first at most)
819	!--------------------------------------------------------------------------------------------------------------------------
820	DO i2=1,nt2; tnam = TRIM(t2(i2)%name) !=== LOOP ON COMMON TRACERS
821	!--------------------------------------------------------------------------------------------------------------------------
822	i1 = ixct(i2); IF(i1 == 0) CYCLE !--- Idx in t1(:) ; skip new tracers
823
824	!=== CHECK WETHER ESSENTIAL KEYS ARE IDENTICAL OR NOT
825	s1=' of "'//TRIM(tnam)//'" in "'//TRIM(sections(is)%name)//'" not matching previous value'
826
827	IF(test(fmsg('Parent name'//TRIM(s1), modname, t1(i1)%parent /= t2(i2)%parent), lerr)) RETURN
828	IF(test(fmsg('Type' //TRIM(s1), modname, t1(i1)%type /= t2(i2)%type), lerr)) RETURN
829	IF(test(fmsg('Generation' //TRIM(s1), modname, t1(i1)%iGeneration /= t2(i2)%iGeneration), lerr)) RETURN
830
831	!=== APPEND <key>=<val> PAIRS NOT PREVIOULSLY DEFINED
832	nk2 = SIZE(t2(i2)%keys%key(:)) !--- Keys number in current section
833	ixck = strIdx(t1(i1)%keys%key(:), t2(i2)%keys%key(:)) !--- Common keys indexes
834
835	!=== APPEND NEW KEYS
836	tr(i1)%keys%key = [ tr(i1)%keys%key, PACK(tr(i2)%keys%key, MASK = ixck==0)]
837	tr(i1)%keys%val = [ tr(i1)%keys%val, PACK(tr(i2)%keys%val, MASK = ixck==0)]
838
839	!--- KEEP TRACK OF THE COMPONENTS NAMES
840	tr(i1)%component = TRIM(tr(i1)%component)//','//TRIM(tr(i2)%component)
841
842	!--- SELECT COMMON TRACERS WITH DIFFERING KEYS VALUES (PREVIOUS VALUE IS KEPT)
843	DO k2=1,nk2
844	k1 = ixck(k2); IF(k1 == 0) CYCLE
845	IF(t1(i1)%keys%val(k1) == t2(i2)%keys%val(k2)) ixck(k2)=0
846	END DO
847	IF(ALL(ixck==0)) CYCLE !--- No identical keys with /=values
848
849	!--- DISPLAY INFORMATION: OLD VALUES ARE KEPT FOR THE KEYS FOUND IN PREVIOUS AND CURRENT SECTIONS
850	CALL msg('Key(s)'//TRIM(s1), modname)
851	DO k2 = 1, nk2 !--- Loop on keys found in both t1(:) and t2(:)
852	knam = t2(i2)%keys%key(k2) !--- Name of the current key
853	k1 = ixck(k2) !--- Corresponding index in t1(:)
854	IF(k1 == 0) CYCLE !--- New keys are skipped
855	v1 = t1(i1)%keys%val(k1); v2 = t2(i2)%keys%val(k2) !--- Key values in t1(:) and t2(:)
856	CALL msg(' * '//TRIM(knam)//'='//TRIM(v2)//' ; previous value kept:'//TRIM(v1), modname)
857	END DO
858	!------------------------------------------------------------------------------------------------------------------------
859	END DO
860	!--------------------------------------------------------------------------------------------------------------------------
861	END DO
862	CALL sortTracers(tr)
863
864	END FUNCTION mergeTracers
865	!==============================================================================================================================
866
867	!==============================================================================================================================
868	LOGICAL FUNCTION cumulTracers(sections, tr) RESULT(lerr)
869	TYPE(dataBase_type), TARGET, INTENT(IN) :: sections(:)
870	TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: tr(:)
871	TYPE(trac_type), POINTER :: t1(:), t2(:)
872	INTEGER, ALLOCATABLE :: nt(:)
873	CHARACTER(LEN=maxlen) :: tnam, tnam_new
874	INTEGER :: iq, nq, is, ns, nsec
875	lerr = .FALSE. !--- Can't fail ; kept to match "mergeTracer" interface.
876	nsec = SIZE(sections)
877	tr = [( sections(is)%trac(:) , is=1, nsec )] !--- Concatenated tracers vector
878	nt = [( SIZE(sections(is)%trac(:)), is=1, nsec )] !--- Number of tracers in each section
879	!----------------------------------------------------------------------------------------------------------------------------
880	DO is=1, nsec !=== LOOP ON SECTIONS
881	!----------------------------------------------------------------------------------------------------------------------------
882	t1 => sections(is)%trac(:)
883	!--------------------------------------------------------------------------------------------------------------------------
884	DO iq=1, nt(is) !=== LOOP ON TRACERS
885	!--------------------------------------------------------------------------------------------------------------------------
886	tnam = TRIM(t1(iq)%name) !--- Original name
887	IF(COUNT(t1%name == tnam) == 1) CYCLE !--- Current tracer is not duplicated: finished
888	tnam_new = TRIM(tnam)//'_'//TRIM(sections(is)%name) !--- Same with section extension
889	nq = SUM(nt(1:is-1)) !--- Number of tracers in previous sections
890	ns = nt(is) !--- Number of tracers in the current section
891	tr(iq + nq)%name = TRIM(tnam_new) !--- Modify tracer name
892	WHERE(tr(1+nq:ns+nq)%parent==tnam) tr(1+nq:ns+nq)%parent=tnam_new !--- Modify parent name
893	!--------------------------------------------------------------------------------------------------------------------------
894	END DO
895	!----------------------------------------------------------------------------------------------------------------------------
896	END DO
897	!----------------------------------------------------------------------------------------------------------------------------
898	CALL sortTracers(tr)
899	END FUNCTION cumulTracers
900	!==============================================================================================================================
901
902	!==============================================================================================================================
903	SUBROUTINE setDirectKeys(tr)
904	TYPE(trac_type), INTENT(INOUT) :: tr(:)
905
906	!--- Update %iqParent, %iqDescen, %nqDescen, %nqChildren
907	CALL indexUpdate(tr)
908
909	!--- Extract some direct-access keys
910	! DO iq = 1, SIZE(tr)
911	! tr(iq)%keys%<key> = getKey_prv(it, "<key>", tr%keys, <default_value> )
912	! END DO
913	END SUBROUTINE setDirectKeys
914	!==============================================================================================================================
915
916	!==============================================================================================================================
917	LOGICAL FUNCTION dispTraSection(message, sname, modname) RESULT(lerr)
918	CHARACTER(LEN=*), INTENT(IN) :: message, sname, modname
919	INTEGER :: idb, iq, nq
920	INTEGER, ALLOCATABLE :: hadv(:), vadv(:)
921	CHARACTER(LEN=maxlen), ALLOCATABLE :: phas(:), prnt(:)
922	TYPE(trac_type), POINTER :: tm(:)
923	lerr = .FALSE.
924	idb = strIdx(dBase(:)%name, sname); IF(idb == 0) RETURN
925	tm => dBase(idb)%trac
926	nq = SIZE(tm)
927	!--- BEWARE ! Can't use the "getKeyByName" functions yet.
928	! Names must first include the phases for tracers defined on multiple lines.
929	hadv = str2int(fgetKeys('hadv', tm(:)%keys, '10'))
930	vadv = str2int(fgetKeys('vadv', tm(:)%keys, '10'))
931	prnt = fgetKeys('parent',tm(:)%keys, '' )
932	IF(getKey('phases', phas, ky=tm(:)%keys)) phas = fGetKeys('phase', tm(:)%keys, 'g')
933	CALL msg(TRIM(message)//':', modname)
934	IF(ALL(prnt == 'air')) THEN
935	IF(test(dispTable('iiiss', ['iq ','hadv ','vadv ','name ','phase '], cat(tm%name, phas), &
936	cat([(iq, iq=1, nq)], hadv, vadv), nColMax=maxTableWidth, nHead=2, sub=modname), lerr)) RETURN
937	ELSE IF(ALL(tm%iGeneration == -1)) THEN
938	IF(test(dispTable('iiisss', ['iq ','hadv ','vadv ','name ','parent','phase '], cat(tm%name, prnt, phas), &
939	cat([(iq, iq=1, nq)], hadv, vadv), nColMax=maxTableWidth, nHead=2, sub=modname), lerr)) RETURN
940	ELSE
941	IF(test(dispTable('iiissis', ['iq ','hadv ','vadv ','name ','parent','igen ','phase '], cat(tm%name, prnt, phas), &
942	cat([(iq, iq=1, nq)], hadv, vadv, tm%iGeneration), nColMax=maxTableWidth, nHead=2, sub=modname), lerr)) RETURN
943	END IF
944	END FUNCTION dispTraSection
945	!==============================================================================================================================
946
947
948	!==============================================================================================================================
949	!== CREATE A SCALAR ALIAS OF THE COMPONENT OF THE TRACERS DESCRIPTOR "t" NAMED "tname" ========================================
950	!==============================================================================================================================
951	FUNCTION aliasTracer(tname, t) RESULT(out)
952	TYPE(trac_type), POINTER :: out
953	CHARACTER(LEN=*), INTENT(IN) :: tname
954	TYPE(trac_type), TARGET, INTENT(IN) :: t(:)
955	INTEGER :: it
956	it = strIdx(t(:)%name, tname)
957	out => NULL(); IF(it /= 0) out => t(it)
958	END FUNCTION aliasTracer
959	!==============================================================================================================================
960
961
962	!==============================================================================================================================
963	!=== FROM A LIST OF INDEXES OR NAMES, CREATE A SUBSET OF THE TRACERS DESCRIPTORS LIST "trac" ==================================
964	!==============================================================================================================================
965	FUNCTION trSubset_Indx(trac,idx) RESULT(out)
966	TYPE(trac_type), ALLOCATABLE :: out(:)
967	TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:)
968	INTEGER, INTENT(IN) :: idx(:)
969	out = trac(idx)
970	CALL indexUpdate(out)
971	END FUNCTION trSubset_Indx
972	!------------------------------------------------------------------------------------------------------------------------------
973	FUNCTION trSubset_Name(trac,nam) RESULT(out)
974	TYPE(trac_type), ALLOCATABLE :: out(:)
975	TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:)
976	CHARACTER(LEN=*), INTENT(IN) :: nam(:)
977	out = trac(strIdx(trac(:)%name, nam))
978	CALL indexUpdate(out)
979	END FUNCTION trSubset_Name
980	!==============================================================================================================================
981
982
983	!==============================================================================================================================
984	!=== CREATE THE SUBSET OF THE TRACERS DESCRIPTORS LIST "trac" HAVING THE FIRST GENERATION ANCESTOR NAMED "nam" ================
985	!==============================================================================================================================
986	FUNCTION trSubset_gen0Name(trac,nam) RESULT(out)
987	TYPE(trac_type), ALLOCATABLE :: out(:)
988	TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:)
989	CHARACTER(LEN=*), INTENT(IN) :: nam
990	out = trac(strFind(delPhase(trac(:)%gen0Name), nam))
991	CALL indexUpdate(out)
992	END FUNCTION trSubset_gen0Name
993	!==============================================================================================================================
994
995
996	!==============================================================================================================================
997	!=== UPDATE THE INDEXES iqParent, iqDescend AND iGeneration IN THE TRACERS DESCRIPTOR LIST "tr" (USEFULL FOR SUBSETS) =========
998	!==============================================================================================================================
999	SUBROUTINE indexUpdate(tr)
1000	TYPE(trac_type), INTENT(INOUT) :: tr(:)
1001	INTEGER :: iq, ig, ng, igen, ngen, ix(SIZE(tr))
1002	tr(:)%iqParent = strIdx( tr(:)%name, tr(:)%parent ) !--- Parent index
1003	DO iq = 1, SIZE(tr); CALL addKey_1('iqParent', int2str(tr(iq)%iqParent), tr(iq)%keys); END DO
1004	ngen = MAXVAL(tr(:)%iGeneration, MASK=.TRUE.)
1005	DO iq = 1, SIZE(tr)
1006	ig = tr(iq)%iGeneration
1007	IF(ALLOCATED(tr(iq)%iqDescen)) DEALLOCATE(tr(iq)%iqDescen)
1008	ALLOCATE(tr(iq)%iqDescen(0))
1009	CALL idxAncestor(tr, ix, ig) !--- Ancestor of generation "ng" for each tr
1010	DO igen = ig+1, ngen
1011	tr(iq)%iqDescen = [tr(iq)%iqDescen, find(ix==iq .AND. tr%iGeneration==igen)]
1012	tr(iq)%nqDescen = SIZE(tr(iq)%iqDescen)
1013	IF(igen == ig+1) THEN
1014	tr(iq)%nqChildren = tr(iq)%nqDescen
1015	CALL addKey_1('nqChildren', int2str(tr(iq)%nqChildren), tr(iq)%keys)
1016	END IF
1017	END DO
1018	CALL addKey_1('iqDescen', strStack(int2str(tr(iq)%iqDescen)), tr(iq)%keys)
1019	CALL addKey_1('nqDescen', int2str(tr(iq)%nqDescen) , tr(iq)%keys)
1020	END DO
1021	print*,'coin9'
1022	END SUBROUTINE indexUpdate
1023	!==============================================================================================================================
1024
1025
1026	!==============================================================================================================================
1027	!=== READ FILE "fnam" TO APPEND THE "dBase" TRACERS DATABASE WITH AS MUCH SECTIONS AS PARENTS NAMES IN "isot(:)%parent": ====
1028	!=== * Each section dBase(i)%name contains the isotopes "dBase(i)%trac(:)" descending on "dBase(i)%name"="iso(i)%parent" ====
1029	!=== * For each isotopes class, the <key>=<val> vector of each tracer is moved into the isotopes descriptor "isot" ====
1030	!=== NOTES: ====
1031	!=== * Most of the "isot" components have been defined in the calling routine (readIsotopes): ====
1032	!=== parent, nzone, zone(:), niso, keys(:)%name, ntiso, trac(:), nphas, phas, iqIsoPha(:,:), itZonPhi(:,:) ====
1033	!=== * Same syntax for isotopes file and "tracer.def": a tracers section contains one line for each of its isotopes ====
1034	!=== * Each tracers section can contain a "params" virtual isotope line of isotopes parameters default values ====
1035	!=== * In case keys are found both in the "params" section and the "*.def" file, the later value is retained ====
1036	!=== * On each isotope line, defined keys can be used for other keys defintions (single level depth substitution) ====
1037	!=== * The routine gives an error if a required isotope is not available in the database stored in "fnam" ====
1038	!==============================================================================================================================
1039	LOGICAL FUNCTION readIsotopesFile_prv(fnam, isot) RESULT(lerr)
1040	CHARACTER(LEN=*), INTENT(IN) :: fnam !--- Input file name
1041	TYPE(isot_type), TARGET, INTENT(INOUT) :: isot(:) !--- Isotopes descriptors (field %parent must be defined!)
1042	INTEGER :: ik, is, it, idb, nk0, i, iis
1043	INTEGER :: nk, ns, nt, ndb, nb0, i0
1044	CHARACTER(LEN=maxlen), POINTER :: k(:), v(:), k0(:), v0(:)
1045	CHARACTER(LEN=maxlen), ALLOCATABLE :: vals(:)
1046	CHARACTER(LEN=maxlen) :: val, modname
1047	TYPE(keys_type), POINTER :: ky(:)
1048	TYPE(trac_type), POINTER :: tt(:), t
1049	TYPE(dataBase_type), ALLOCATABLE :: tdb(:)
1050	modname = 'readIsotopesFile'
1051
1052	!--- THE INPUT FILE MUST BE PRESENT
1053	IF(test(fmsg('Missing isotopes parameters file "'//TRIM(fnam)//'"', modname, testFile(fnam)),lerr)) RETURN
1054
1055	!--- READ THE FILE SECTIONS, ONE EACH PARENT TRACER
1056	nb0 = SIZE(dBase, DIM=1)+1 !--- Next database element index
1057	IF(test(readSections(fnam,strStack(isot(:)%parent,'\|')),lerr)) RETURN !--- Read sections, one each parent tracer
1058	ndb = SIZE(dBase, DIM=1) !--- Current database size
1059	DO idb = nb0, ndb
1060	iis = idb-nb0+1
1061
1062	!--- GET FEW GLOBAL KEYS FROM "def" FILES AND ADD THEM TO THE 'params' SECTION
1063	CALL addKeysFromDef(dBase(idb)%trac, 'params')
1064
1065	!--- SUBSTITUTE THE KEYS DEFINED IN THE 'params' VIRTUAL TRACER ; SUBSTITUTE LOCAL KEYS ; REMOVE 'params' VIRTUAL TRACER
1066	CALL subDefault(dBase(idb)%trac, 'params', .TRUE.)
1067
1068	tt => dBase(idb)%trac
1069
1070	!--- REDUCE THE EXPRESSIONS TO OBTAIN SCALARS AND TRANSFER THEM TO THE "isot" ISOTOPES DESCRIPTORS VECTOR
1071	DO it = 1, SIZE(dBase(idb)%trac)
1072	t => dBase(idb)%trac(it)
1073	is = strIdx(isot(iis)%keys(:)%name, t%name) !--- Index in "isot(iis)%keys(:)%name" of isotope "t%name"
1074	IF(is == 0) CYCLE
1075	IF(test(ANY(reduceExpr(t%keys%val, vals)), lerr)) RETURN !--- Reduce expressions ; detect non-numerical elements
1076	isot(iis)%keys(is)%key = t%keys%key
1077	isot(iis)%keys(is)%val = vals
1078	END DO
1079
1080	!--- CHECK FOR MISSING ISOTOPES (NO KEYS ALLOCATED)
1081	IF(test(checkList(isot(iis)%keys(:)%name, .NOT.[( ALLOCATED(isot(iis)%keys(is)%key), is=1, SIZE(isot(iis)%keys) )], &
1082	'Check file "'//TRIM(fnam)//'" in section "'//TRIM(dBase(idb)%name)//'"', 'isotopes', 'missing'), lerr)) RETURN
1083	END DO
1084
1085	!--- CLEAN THE DATABASE ENTRIES
1086	IF(nb0 == 1) THEN
1087	DEALLOCATE(dBase); ALLOCATE(dBase(0))
1088	ELSE
1089	ALLOCATE(tdb(nb0-1)); tdb(1:nb0-1)=dBase(1:nb0-1); CALL MOVE_ALLOC(FROM=tdb, TO=dBase)
1090	END IF
1091
1092	!--- GET THE isoCheck ENTRY FROM THE *.DEF FILES (MIGHT BE CHANGED TO A CLASS-DEPENDANT KEYWORD)
1093	CALL get_in('ok_iso_verif', isot(strIdx(isot%parent, 'H2O'))%check, .FALSE.)
1094
1095	lerr = dispIsotopes()
1096
1097	CONTAINS
1098
1099	!------------------------------------------------------------------------------------------------------------------------------
1100	LOGICAL FUNCTION dispIsotopes() RESULT(lerr)
1101	INTEGER :: ik, nk, ip, it, nt
1102	CHARACTER(LEN=maxlen) :: prf
1103	CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:), val(:,:)
1104	CALL msg('Isotopes parameters read from file "'//TRIM(fnam)//'":', modname)
1105	DO ip = 1, SIZE(isot) !--- Loop on parents tracers
1106	nk = SIZE(isot(ip)%keys(1)%key) !--- Same keys for each isotope
1107	nt = SIZE(isot(ip)%keys) !--- Number of isotopes
1108	prf = 'i'//REPEAT('s',nk+1) !--- Profile for table printing
1109	ALLOCATE(ttl(nk+2), val(nt,nk+1))
1110	ttl(1:2) = ['it ','name']; ttl(3:nk+2) = isot(ip)%keys(1)%key(:)!--- Titles line with keys names
1111	val(:,1) = isot(ip)%keys(:)%name !--- Values table 1st column: isotopes names
1112	DO ik = 1, nk
1113	DO it = 1, nt
1114	val(it,ik+1) = isot(ip)%keys(it)%val(ik) !--- Other columns: keys values
1115	END DO
1116	END DO
1117	IF(test(fmsg('Problem with the table content', modname, dispTable(prf, ttl, val, &
1118	cat([(it,it=1,nt)]), rFmt='(EN8.4)', nColMax=maxTableWidth, nHead=2, sub=modname)), lerr)) RETURN
1119	DEALLOCATE(ttl, val)
1120	END DO
1121	END FUNCTION dispIsotopes
1122	!------------------------------------------------------------------------------------------------------------------------------
1123
1124	END FUNCTION readIsotopesFile_prv
1125	!==============================================================================================================================
1126
1127
1128	!==============================================================================================================================
1129	!=== IF ISOTOPES (2ND GENERATION TRACERS) ARE DETECTED: ===
1130	!=== * COMPUTE MOST OF THE RELATED QUANTITIES ("isot" COMPONENTS). ===
1131	!=== * COMPUTE FEW ISOTOPES-DEDICATED "trac" COMPONENTS ===
1132	!=== * CALL readIsotopesFile_prv TO GET PHYSICAL QUANTITIES (<key>=<val> PAIRS) ===
1133	!=== NOTE: THIS IS DONE HERE (IN A ROUTINE CALLED BY THE DYNAMIC), BECAUSE THE DYNAMIC NEEDS FEW PHYSICAL PARAMETERS. ===
1134	!==============================================================================================================================
1135	LOGICAL FUNCTION readIsotopesFile(iNames) RESULT(lerr)
1136	CHARACTER(LEN=maxlen), TARGET, OPTIONAL, INTENT(IN) :: iNames(:)
1137	CHARACTER(LEN=maxlen), ALLOCATABLE :: p(:), str(:) !--- Temporary storage
1138	CHARACTER(LEN=maxlen) :: iName, modname
1139	CHARACTER(LEN=1) :: ph !--- Phase
1140	INTEGER :: ic, ip, iq, it, iz
1141	LOGICAL, ALLOCATABLE :: ll(:) !--- Mask
1142	TYPE(trac_type), POINTER :: t(:), t1
1143	TYPE(isot_type), POINTER :: i
1144	lerr = .FALSE.
1145	modname = 'readIsotopesFile'
1146
1147	t => tracers
1148
1149	!--- GET FROM "tracers" THE FULL LIST OF AVAILABLE ISOTOPES CLASSES
1150	p = PACK(delPhase(t%parent), MASK = t%type=='tracer' .AND. t%iGeneration==1)
1151	CALL strReduce(p, nbIso)
1152
1153	!--- CHECK WHETHER NEEDED ISOTOPES CLASSES "iNames" ARE AVAILABLE OR NOT
1154	IF(PRESENT(iNames)) THEN
1155	DO it = 1, SIZE(iNames)
1156	IF(test(fmsg('No isotopes class "'//TRIM(iNames(it))//'" found among tracers', modname, ALL(p /= iNames(it))), lerr)) RETURN
1157	END DO
1158	p = iNames; nbIso = SIZE(p)
1159	END IF
1160	IF(ALLOCATED(isotopes)) DEALLOCATE(isotopes)
1161	ALLOCATE(isotopes(nbIso))
1162
1163	IF(nbIso==0) RETURN !=== NO ISOTOPES: FINISHED
1164
1165	!--- ISOTOPES RELATED VARIABLES ; NULL OR EMPTY IF NO ISOTOPES
1166	isotopes(:)%parent = p
1167	DO ic = 1, SIZE(p) !--- Loop on isotopes classes
1168	i => isotopes(ic)
1169	iname = i%parent !--- Current isotopes class name (parent tracer name)
1170
1171	!=== Isotopes children of tracer "iname": mask, names, number (same for each phase of "iname")
1172	ll = t(:)%type=='tracer' .AND. delPhase(t(:)%parent) == iname .AND. t(:)%phase == 'g'
1173	str = PACK(delPhase(t(:)%name), MASK = ll) !--- Effectively found isotopes of "iname"
1174	i%niso = SIZE(str) !--- Number of "effectively found isotopes of "iname"
1175	ALLOCATE(i%keys(i%niso))
1176	FORALL(it = 1:i%niso) i%keys(it)%name = str(it)
1177
1178	!=== Geographic tagging tracers descending on tracer "iname": mask, names, number
1179	ll = t(:)%type=='tag' .AND. delPhase(t(:)%gen0Name) == iname .AND. t(:)%iGeneration == 2
1180	i%zone = PACK(strTail(t(:)%name,'_'), MASK = ll) !--- Tagging zones names for isotopes category "iname"
1181	CALL strReduce(i%zone)
1182	i%nzone = SIZE(i%zone) !--- Tagging zones number for isotopes category "iname"
1183
1184	!=== Geographic tracers of the isotopes children of tracer "iname" (same for each phase of "iname")
1185	! NOTE: One might like to create a similar variable for 2nd generation tagging tracers (tagging the gen1 tracers)
1186	str = PACK(delPhase(t(:)%name), MASK=ll)
1187	CALL strReduce(str)
1188	i%ntiso = i%niso + SIZE(str) !--- Number of isotopes + their geographic tracers [ntiso]
1189	ALLOCATE(i%trac(i%ntiso))
1190	FORALL(it = 1:i%niso) i%trac(it) = i%keys(it)%name
1191	FORALL(it = i%niso+1:i%ntiso) i%trac(it) = str(it-i%niso)
1192
1193	!=== Phases for tracer "iname"
1194	i%phase = ''
1195	DO ip = 1, nphases; ph = known_phases(ip:ip); IF(strIdx(t%name,addPhase(iname, ph)) /= 0) i%phase = TRIM(i%phase)//ph; END DO
1196	i%nphas = LEN_TRIM(i%phase) !--- Equal to "nqo" for water
1197
1198	!=== Tables giving the index in a table of effectively found items for each dynamical tracer (1<=iq<=nqtot)
1199	DO iq = 1, SIZE(t)
1200	t1 => tracers(iq)
1201	IF(delPhase(t1%gen0Name)/=iname .OR. t1%iGeneration==0) CYCLE !--- Only deal with tracers descending on "iname"
1202	t1%iso_iGroup = ic !--- Isotopes family idx in list "isotopes(:)%parent"
1203	t1%iso_iName = strIdx(i%trac, delPhase(strHead(t1%name,'_'))) !--- Current isotope idx in effective isotopes list
1204	t1%iso_iZone = strIdx(i%zone, strTail(t1%name,'_') ) !--- Current isotope zone idx in effective zones list
1205	t1%iso_iPhase = INDEX(i%phase,TRIM(t1%phase)) !--- Current isotope phase idx in effective phases list
1206	IF(t1%iGeneration /= 2) t1%iso_iZone = 0 !--- Skip possible generation 1 tagging tracers
1207	END DO
1208
1209	!=== Table used to get iq (index in dyn array, size nqtot) from the isotope and phase indexes ; the full isotopes list
1210	! (including tagging tracers) is sorted this way: iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN
1211	i%iqIsoPha = RESHAPE( [( (strIdx(t%name, addPhase(i%trac(it),i%phase(ip:ip))), it=1, i%ntiso), ip=1, i%nphas)], &
1212	[i%ntiso, i%nphas] )
1213	!=== Table used to get ix (index in tagging tracers isotopes list, size ntiso) from the zone and isotope indexes
1214	i%itZonIso = RESHAPE( [( (strIdx(i%trac(:), TRIM(i%trac(it))//'_'//TRIM(i%zone(iz))), iz=1, i%nzone), it=1, i%niso )], &
1215	[i%nzone, i%niso] )
1216	END DO
1217
1218	!=== READ PHYSICAL PARAMETERS FROM isoFile FILE
1219	IF(test(readIsotopesFile_prv(isoFile, isotopes), lerr)) RETURN
1220
1221	!=== CHECK CONSISTENCY
1222	IF(test(testIsotopes(), lerr)) RETURN
1223
1224	!=== SELECT FIRST ISOTOPES CLASS OR, IF POSSIBLE, WATER CLASS
1225	IF(.NOT.test(isoSelect(1, .TRUE.), lerr)) THEN; IF(isotope%parent == 'H2O') iH2O = ixIso; END IF
1226
1227	CONTAINS
1228
1229	!------------------------------------------------------------------------------------------------------------------------------
1230	LOGICAL FUNCTION testIsotopes() RESULT(lerr) !--- MAKE SURE MEMBERS OF AN ISOTOPES FAMILY ARE PRESENT IN THE SAME PHASES
1231	!------------------------------------------------------------------------------------------------------------------------------
1232	INTEGER :: ix, it, ip, np, iz, nz
1233	TYPE(isot_type), POINTER :: i
1234	DO ix = 1, nbIso
1235	i => isotopes(ix)
1236	!--- Check whether each isotope and tagging isotopic tracer is present in the same number of phases
1237	DO it = 1, i%ntiso
1238	np = SUM([(COUNT(tracers(:)%name == addPhase(i%trac(it), i%phase(ip:ip))), ip=1, i%nphas)])
1239	IF(test(fmsg(TRIM(int2str(np))//' phases instead of '//TRIM(int2str(i%nphas))//' for '//TRIM(i%trac(it)), &
1240	modname, np /= i%nphas), lerr)) RETURN
1241	END DO
1242	DO it = 1, i%niso
1243	nz = SUM([(COUNT(i%trac == TRIM(i%trac(it))//'_'//i%zone(iz)), iz=1, i%nzone)])
1244	IF(test(fmsg(TRIM(int2str(nz))//' tagging zones instead of '//TRIM(int2str(i%nzone))//' for '//TRIM(i%trac(it)), &
1245	modname, nz /= i%nzone), lerr)) RETURN
1246	END DO
1247	END DO
1248	END FUNCTION testIsotopes
1249	!------------------------------------------------------------------------------------------------------------------------------
1250
1251	END FUNCTION readIsotopesFile
1252	!==============================================================================================================================
1253
1254
1255	!==============================================================================================================================
1256	!=== THE ROUTINE isoSelect IS USED TO SWITCH FROM AN ISOTOPE FAMILY TO ANOTHER: ISOTOPES DEPENDENT PARAMETERS ARE UPDATED
1257	! Single generic "isoSelect" routine, using the predefined index of the parent (fast version) or its name (first call).
1258	!==============================================================================================================================
1259	LOGICAL FUNCTION isoSelectByName(iName, lVerbose) RESULT(lerr)
1260	IMPLICIT NONE
1261	CHARACTER(LEN=*), INTENT(IN) :: iName
1262	LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose
1263	INTEGER :: iIso
1264	LOGICAL :: lV
1265	lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose
1266	iIso = strIdx(isotopes(:)%parent, iName)
1267	IF(test(iIso == 0, lerr)) THEN
1268	niso = 0; ntiso = 0; nzone = 0; nphas = 0; isoCheck=.FALSE.
1269	CALL msg('no isotope family named "'//TRIM(iName)//'"', ll=lV)
1270	RETURN
1271	END IF
1272	lerr = isoSelectByIndex(iIso, lV)
1273	END FUNCTION isoSelectByName
1274	!==============================================================================================================================
1275	LOGICAL FUNCTION isoSelectByIndex(iIso, lVerbose) RESULT(lerr)
1276	IMPLICIT NONE
1277	INTEGER, INTENT(IN) :: iIso
1278	LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose
1279	LOGICAL :: lV
1280	lv = .FALSE.; IF(PRESENT(lVerbose)) lv = lVerbose
1281	lerr = .FALSE.
1282	IF(iIso == ixIso) RETURN !--- Nothing to do if the index is already OK
1283	lerr = iIso<=0 .OR. iIso>SIZE(isotopes)
1284	CALL msg('Inconsistent isotopes family index '//TRIM(int2str(iIso))//': should be > 0 and <= '&
1285	//TRIM(int2str(SIZE(isotopes)))//'"', ll = lerr .AND. lV)
1286	IF(lerr) RETURN
1287	ixIso = iIso !--- Update currently selected family index
1288	isotope => isotopes(ixIso) !--- Select corresponding component
1289	isoKeys => isotope%keys; niso = isotope%niso
1290	isoName => isotope%trac; ntiso = isotope%ntiso
1291	isoZone => isotope%zone; nzone = isotope%nzone
1292	isoPhas => isotope%phase; nphas = isotope%nphas
1293	itZonIso => isotope%itZonIso; isoCheck = isotope%check
1294	iqIsoPha => isotope%iqIsoPha
1295	END FUNCTION isoSelectByIndex
1296	!==============================================================================================================================
1297
1298
1299	!==============================================================================================================================
1300	!=== ADD THE <key>=<val> PAIR TO THE "ky[(:)]" KEY[S] DESCRIPTOR[S] OR THE <key>=<val(:)> PAIRS TO THE "ky(:)" KEYS DESCRIPTORS
1301	!==============================================================================================================================
1302	SUBROUTINE addKey_1(key, val, ky, lOverWrite)
1303	CHARACTER(LEN=*), INTENT(IN) :: key, val
1304	TYPE(keys_type), INTENT(INOUT) :: ky
1305	LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite
1306	!------------------------------------------------------------------------------------------------------------------------------
1307	CHARACTER(LEN=maxlen), ALLOCATABLE :: k(:), v(:)
1308	INTEGER :: iky, nky
1309	LOGICAL :: lo
1310	lo=.TRUE.; IF(PRESENT(lOverWrite)) lo=lOverWrite
1311	iky = strIdx(ky%key,key)
1312	IF(iky == 0) THEN
1313	nky = SIZE(ky%key)
1314	ALLOCATE(k(nky+1)); k(1:nky) = ky%key; k(nky+1) = key; ky%key = k
1315	ALLOCATE(v(nky+1)); v(1:nky) = ky%val; v(nky+1) = val; ky%val = v
1316	ELSE IF(lo) THEN
1317	ky%key(iky) = key; ky%val(iky) = val
1318	END IF
1319	END SUBROUTINE addKey_1
1320	!==============================================================================================================================
1321	SUBROUTINE addKey_m(key, val, ky, lOverWrite)
1322	CHARACTER(LEN=*), INTENT(IN) :: key, val
1323	TYPE(keys_type), INTENT(INOUT) :: ky(:)
1324	LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite
1325	!------------------------------------------------------------------------------------------------------------------------------
1326	INTEGER :: itr
1327	DO itr = 1, SIZE(ky)
1328	CALL addKey_1(key, val, ky(itr), lOverWrite)
1329	PRINT*,'COINCOINCOIN '//TRIM(key)//', '//TRIM(val)//', '//TRIM(ky(itr)%name)
1330	END DO
1331	print*,'COINCOINCOINCOIN'
1332	END SUBROUTINE addKey_m
1333	!==============================================================================================================================
1334	SUBROUTINE addKey_mm(key, val, ky, lOverWrite)
1335	CHARACTER(LEN=*), INTENT(IN) :: key, val(:)
1336	TYPE(keys_type), INTENT(INOUT) :: ky(:)
1337	LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite
1338	!------------------------------------------------------------------------------------------------------------------------------
1339	INTEGER :: itr
1340	DO itr = 1, SIZE(ky); CALL addKey_1(key, val(itr), ky(itr), lOverWrite); END DO
1341	END SUBROUTINE addKey_mm
1342	!==============================================================================================================================
1343
1344
1345	!==============================================================================================================================
1346	!=== OVERWRITE THE KEYS OF THE TRACER NAMED "tr0" WITH THE VALUES FOUND IN THE *.def FILES, IF ANY. ===========================
1347	!==============================================================================================================================
1348	SUBROUTINE addKeysFromDef(t, tr0)
1349	TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: t(:)
1350	CHARACTER(LEN=*), INTENT(IN) :: tr0
1351	!------------------------------------------------------------------------------------------------------------------------------
1352	CHARACTER(LEN=maxlen) :: val
1353	INTEGER :: ik, jd
1354	jd = strIdx(t%name, tr0)
1355	IF(jd == 0) RETURN
1356	DO ik = 1, SIZE(t(jd)%keys%key)
1357	CALL get_in(t(jd)%keys%key(ik), val, 'none')
1358	IF(val /= 'none') CALL addKey_1(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.)
1359	END DO
1360	END SUBROUTINE addKeysFromDef
1361	!==============================================================================================================================
1362
1363
1364	!==============================================================================================================================
1365	!=== REMOVE THE KEYS NAMED "keyn(:)" FROM EITHER THE "itr"th OR ALL THE KEYS DESCRIPTORS OF "ky(:)" ===========================
1366	!==============================================================================================================================
1367	SUBROUTINE delKey_1(itr, keyn, ky)
1368	INTEGER, INTENT(IN) :: itr
1369	CHARACTER(LEN=*), INTENT(IN) :: keyn(:)
1370	TYPE(trac_type), INTENT(INOUT) :: ky(:)
1371	!------------------------------------------------------------------------------------------------------------------------------
1372	CHARACTER(LEN=maxlen), ALLOCATABLE :: k(:), v(:)
1373	LOGICAL, ALLOCATABLE :: ll(:)
1374	INTEGER :: iky
1375	IF(itr<=0 .OR. itr>SIZE(ky, DIM=1)) RETURN !--- Index is out of range
1376	ll = [( ALL(keyn/=ky(itr)%keys%key(iky)), iky=1, SIZE(ky(itr)%keys%key) )]
1377	k = PACK(ky(itr)%keys%key, MASK=ll); CALL MOVE_ALLOC(FROM=k, TO=ky(itr)%keys%key)
1378	v = PACK(ky(itr)%keys%val, MASK=ll); CALL MOVE_ALLOC(FROM=v, TO=ky(itr)%keys%val)
1379	END SUBROUTINE delKey_1
1380	!==============================================================================================================================
1381	SUBROUTINE delKey(keyn, ky)
1382	CHARACTER(LEN=*), INTENT(IN) :: keyn(:)
1383	TYPE(trac_type), INTENT(INOUT) :: ky(:)
1384	!------------------------------------------------------------------------------------------------------------------------------
1385	INTEGER :: iky
1386	DO iky = 1, SIZE(ky); CALL delKey_1(iky, keyn, ky); END DO
1387	END SUBROUTINE delKey
1388	!==============================================================================================================================
1389
1390
1391	!==============================================================================================================================
1392	!================ GET THE VALUE OF A KEY FROM A "keys_type" DERIVED TYPE ; THE RESULT IS THE RETURNED VALUE ===================
1393	!==============================================================================================================================
1394	CHARACTER(LEN=maxlen) FUNCTION fgetKeyIdx_s1(itr, keyn, ky, def_val, lerr) RESULT(val)
1395	INTEGER, INTENT(IN) :: itr
1396	CHARACTER(LEN=*), INTENT(IN) :: keyn
1397	TYPE(keys_type), INTENT(IN) :: ky(:)
1398	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def_val
1399	LOGICAL, OPTIONAL, INTENT(OUT) :: lerr
1400	!------------------------------------------------------------------------------------------------------------------------------
1401	INTEGER :: iky
1402	LOGICAL :: ler
1403	iky = 0; val = ''
1404	IF(.NOT.test(itr <= 0 .OR. itr > SIZE(ky), ler)) iky = strIdx(ky(itr)%key(:), keyn) !--- Correct index
1405	IF(.NOT.test(iky == 0, ler)) val = ky(itr)%val(iky) !--- Found key
1406	IF(iky == 0) THEN
1407	IF(.NOT.test(.NOT.PRESENT(def_val), ler)) val = def_val !--- Default value
1408	END IF
1409	IF(PRESENT(lerr)) lerr = ler
1410	END FUNCTION fgetKeyIdx_s1
1411	!==============================================================================================================================
1412	CHARACTER(LEN=maxlen) FUNCTION fgetKeyNam_s1(tname, keyn, ky, def_val, lerr) RESULT(val)
1413	CHARACTER(LEN=*), INTENT(IN) :: tname, keyn
1414	TYPE(keys_type), INTENT(IN) :: ky(:)
1415	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def_val
1416	LOGICAL, OPTIONAL, INTENT(OUT) :: lerr
1417	!------------------------------------------------------------------------------------------------------------------------------
1418	val = fgetKeyIdx_s1(strIdx(ky(:)%name, tname), keyn, ky, def_val, lerr)
1419	END FUNCTION fgetKeyNam_s1
1420	!==============================================================================================================================
1421	FUNCTION fgetKeys(keyn, ky, def_val, lerr) RESULT(val)
1422	CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:)
1423	CHARACTER(LEN=*), INTENT(IN) :: keyn
1424	TYPE(keys_type), INTENT(IN) :: ky(:)
1425	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def_val
1426	LOGICAL, OPTIONAL, INTENT(OUT) :: lerr
1427	!------------------------------------------------------------------------------------------------------------------------------
1428	LOGICAL :: ler(SIZE(ky))
1429	INTEGER :: it
1430	val = [(fgetKeyIdx_s1(it, keyn, ky, def_val, ler(it)), it = 1, SIZE(ky))]
1431	IF(PRESENT(lerr)) lerr = ANY(ler)
1432	END FUNCTION fgetKeys
1433	!==============================================================================================================================
1434
1435
1436	!==============================================================================================================================
1437	!========== GET THE VALUE OF A KEY FROM A "keys_type" DERIVED TYPE ; THE RETURNED VALUE IS THE ERROR CODE ==============
1438	!========== The key "keyn" is searched in: 1) "ky(:)%name" (if given) ==============
1439	!========== 2) "tracers(:)%name" ==============
1440	!========== 3) "isotope%keys(:)%name" ==============
1441	!========== for the tracer[s] "tname[(:)]" (if given) or all the available tracers from the used set otherwise. ==============
1442	!========== The type of the returned value(s) can be string, integer or real, scalar or vector ==============
1443	!==============================================================================================================================
1444	LOGICAL FUNCTION getKeyByName_s1(keyn, val, tname, ky) RESULT(lerr)
1445	CHARACTER(LEN=*), INTENT(IN) :: keyn
1446	CHARACTER(LEN=maxlen), INTENT(OUT) :: val
1447	CHARACTER(LEN=*), INTENT(IN) :: tname
1448	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1449	!------------------------------------------------------------------------------------------------------------------------------
1450	CHARACTER(LEN=maxlen) :: tnam
1451	tnam = strHead(delPhase(tname),'_',.FALSE.) !--- Remove tag and phase
1452	IF(PRESENT(ky)) THEN !=== KEY FROM "ky"
1453	val = fgetKeyNam_s1(tname, keyn, ky, lerr=lerr) !--- "ky" and "tname"
1454	IF( lerr ) val = fgetKeyNam_s1(tnam, keyn, ky, lerr=lerr) !--- "ky" and "tnam"
1455	ELSE
1456	IF( .NOT.test(.NOT.ALLOCATED(tracers ), lerr)) lerr = SIZE(tracers ) == 0 !=== KEY FROM "tracers"
1457	IF(.NOT.lerr) THEN
1458	val = fgetKeyNam_s1(tname, keyn, tracers%keys, lerr=lerr) !--- "ky" and "tname"
1459	IF(lerr) val = fgetKeyNam_s1(tnam, keyn, tracers%keys, lerr=lerr) !--- "ky" and "tnam"
1460	END IF
1461	IF(lerr.AND..NOT.test(.NOT.ALLOCATED(isotopes), lerr)) lerr = SIZE(isotopes) == 0 !=== KEY FROM "isotope"
1462	IF(.NOT.lerr) THEN
1463	val = fgetKeyNam_s1(tname, keyn, isotope%keys, lerr=lerr) !--- "ky" and "tname"
1464	IF(lerr) val = fgetKeyNam_s1(tnam, keyn, isotope%keys, lerr=lerr) !--- "ky" and "tnam"
1465	END IF
1466	END IF
1467	END FUNCTION getKeyByName_s1
1468	!==============================================================================================================================
1469	LOGICAL FUNCTION getKeyByName_s1m(keyn, val, tname, ky) RESULT(lerr)
1470	CHARACTER(LEN=*), INTENT(IN) :: keyn
1471	CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
1472	CHARACTER(LEN=*), INTENT(IN) :: tname
1473	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1474	!------------------------------------------------------------------------------------------------------------------------------
1475	CHARACTER(LEN=maxlen) :: sval
1476	lerr = getKeyByName_s1(keyn, sval, tname, ky)
1477	IF(test(fmsg('missing key "'//TRIM(keyn)//'" for tracer "'//TRIM(tname)//'"', modname, lerr), lerr)) RETURN
1478	lerr = strParse(sval, ',', val)
1479	END FUNCTION getKeyByName_s1m
1480	!==============================================================================================================================
1481	LOGICAL FUNCTION getKeyByName_sm(keyn, val, tname, ky, nam) RESULT(lerr)
1482	CHARACTER(LEN=*), INTENT(IN) :: keyn
1483	CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
1484	CHARACTER(LEN=*), INTENT(IN) :: tname(:)
1485	TYPE(keys_type), OPTIONAL, TARGET, INTENT(IN) :: ky(:)
1486	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1487	!------------------------------------------------------------------------------------------------------------------------------
1488	TYPE(keys_type), POINTER :: keys(:)
1489	LOGICAL :: lk, lt, li, ll
1490	INTEGER :: iq, nq
1491
1492	!--- DETERMINE THE DATABASE TO BE USED (ky, tracers or isotope)
1493	lk = PRESENT(ky)
1494	lt = .NOT.lk .AND. ALLOCATED(tracers); IF(lt) lt = SIZE(tracers) /= 0; IF(lt) lt = ANY(tracers(1)%keys%key(:) == keyn)
1495	li = .NOT.lt .AND. ALLOCATED(isotopes); IF(li) li = SIZE(isotopes) /= 0; IF(li) li = ANY(isotope%keys(1)%key(:) == keyn)
1496
1497	!--- LINK "keys" TO THE RIGHT DATABASE
1498	IF(test(.NOT.ANY([lk,lt,li]), lerr)) RETURN
1499	IF(lk) keys => ky(:)
1500	IF(lt) keys => tracers(:)%keys
1501	IF(li) keys => isotope%keys(:)
1502
1503	!--- GET THE DATA
1504	nq = SIZE(tname)
1505	ALLOCATE(val(nq))
1506	lerr = ANY([(getKeyByName_s1(keyn, val(iq), tname(iq), keys(:)), iq=1, nq)])
1507	IF(PRESENT(nam)) nam = tname(:)
1508
1509	END FUNCTION getKeyByName_sm
1510	!==============================================================================================================================
1511	LOGICAL FUNCTION getKey_sm(keyn, val, ky, nam) RESULT(lerr)
1512	CHARACTER(LEN=*), INTENT(IN) :: keyn
1513	CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
1514	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1515	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1516	!------------------------------------------------------------------------------------------------------------------------------
1517	! Note: if names are repeated, getKeyByName_sm can't be used ; this routine, using indexes, must be used instead.
1518	IF(PRESENT(ky)) THEN !=== KEY FROM "ky"
1519	val = fgetKeys(keyn, ky, lerr=lerr)
1520	IF(PRESENT(nam)) nam = ky(:)%name
1521	ELSE
1522	IF( .NOT.test(.NOT.ALLOCATED(tracers ), lerr)) lerr = SIZE(tracers ) == 0 !=== KEY FROM "tracers"
1523	IF(.NOT.lerr) val = fgetKeys(keyn, tracers%keys, lerr=lerr)
1524	IF(.NOT.lerr.AND.PRESENT(nam)) nam = tracers(:)%keys%name
1525	IF(lerr.AND..NOT.test(.NOT.ALLOCATED(isotopes), lerr)) lerr = SIZE(isotopes) == 0 !=== KEY FROM "isotope"
1526	IF(.NOT.lerr) val = fgetKeys(keyn, isotope%keys, lerr=lerr)
1527	IF(.NOT.lerr.AND.PRESENT(nam)) nam = isotope%keys(:)%name
1528	END IF
1529	END FUNCTION getKey_sm
1530	!==============================================================================================================================
1531	LOGICAL FUNCTION getKeyByName_i1(keyn, val, tname, ky) RESULT(lerr)
1532	CHARACTER(LEN=*), INTENT(IN) :: keyn
1533	INTEGER, INTENT(OUT) :: val
1534	CHARACTER(LEN=*), INTENT(IN) :: tname
1535	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1536	!------------------------------------------------------------------------------------------------------------------------------
1537	CHARACTER(LEN=maxlen) :: sval
1538	INTEGER :: ierr
1539	lerr = getKeyByName_s1(keyn, sval, tname, ky)
1540	IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tname)//'" is missing', modname, lerr), lerr)) RETURN
1541	READ(sval, *, IOSTAT=ierr) val
1542	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not an integer', modname, ierr/=0), lerr)) RETURN
1543	END FUNCTION getKeyByName_i1
1544	!==============================================================================================================================
1545	LOGICAL FUNCTION getKeyByName_i1m(keyn, val, tname, ky) RESULT(lerr)
1546	CHARACTER(LEN=*), INTENT(IN) :: keyn
1547	INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:)
1548	CHARACTER(LEN=*), INTENT(IN) :: tname
1549	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1550	!------------------------------------------------------------------------------------------------------------------------------
1551	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:)
1552	INTEGER :: ierr, iq, nq
1553	IF(test(getKeyByName_s1m(keyn, sval, tname, ky), lerr)) RETURN
1554	nq = SIZE(sval); ALLOCATE(val(nq))
1555	lerr = .FALSE.; DO iq=1, nq; READ(sval(iq), *, IOSTAT=ierr) val(iq); lerr = lerr .OR. ierr /= 0; END DO
1556	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not an integer', modname, lerr), lerr)) RETURN
1557	END FUNCTION getKeyByName_i1m
1558	!==============================================================================================================================
1559	LOGICAL FUNCTION getKeyByName_im(keyn, val, tname, ky, nam) RESULT(lerr)
1560	CHARACTER(LEN=*), INTENT(IN) :: keyn
1561	INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:)
1562	CHARACTER(LEN=*), INTENT(IN) :: tname(:)
1563	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1564	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1565	!------------------------------------------------------------------------------------------------------------------------------
1566	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:)
1567	INTEGER :: ierr, iq, nq
1568	IF(test(getKeyByName_sm(keyn, sval, tname, ky, names), lerr)) RETURN
1569	nq = SIZE(sval); ALLOCATE(val(nq))
1570	DO iq = 1, nq !--- CONVERT THE KEYS TO INTEGERS
1571	READ(sval(iq), *, IOSTAT=ierr) val(iq)
1572	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not an integer', modname, ierr/=0), lerr)) RETURN
1573	END DO
1574	END FUNCTION getKeyByName_im
1575	!==============================================================================================================================
1576	LOGICAL FUNCTION getKey_im(keyn, val, ky, nam) RESULT(lerr)
1577	CHARACTER(LEN=*), INTENT(IN) :: keyn
1578	INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:)
1579	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1580	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1581	!------------------------------------------------------------------------------------------------------------------------------
1582	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:)
1583	INTEGER :: ierr, iq, nq
1584	IF(test(getKey_sm(keyn, sval, ky, names), lerr)) RETURN
1585	nq = SIZE(sval); ALLOCATE(val(nq))
1586	DO iq = 1, nq
1587	READ(sval(iq), *, IOSTAT=ierr) val(iq)
1588	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not an integer', modname, ierr/=0), lerr)) RETURN
1589	END DO
1590	IF(PRESENT(nam)) nam = names
1591	END FUNCTION getKey_im
1592	!==============================================================================================================================
1593	LOGICAL FUNCTION getKeyByName_r1(keyn, val, tname, ky) RESULT(lerr)
1594	CHARACTER(LEN=*), INTENT(IN) :: keyn
1595	REAL, INTENT(OUT) :: val
1596	CHARACTER(LEN=*), INTENT(IN) :: tname
1597	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1598	!------------------------------------------------------------------------------------------------------------------------------
1599	CHARACTER(LEN=maxlen) :: sval
1600	INTEGER :: ierr
1601	lerr = getKeyByName_s1(keyn, sval, tname, ky)
1602	IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tname)//'" is missing', modname, lerr), lerr)) RETURN
1603	READ(sval, *, IOSTAT=ierr) val
1604	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not a real', modname, ierr/=0), lerr)) RETURN
1605	END FUNCTION getKeyByName_r1
1606	!==============================================================================================================================
1607	LOGICAL FUNCTION getKeyByName_r1m(keyn, val, tname, ky) RESULT(lerr)
1608	CHARACTER(LEN=*), INTENT(IN) :: keyn
1609	REAL, ALLOCATABLE, INTENT(OUT) :: val(:)
1610	CHARACTER(LEN=*), INTENT(IN) :: tname
1611	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1612	!------------------------------------------------------------------------------------------------------------------------------
1613	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:)
1614	INTEGER :: ierr, iq, nq
1615	IF(test(getKeyByName_s1m(keyn, sval, tname, ky), lerr)) RETURN
1616	nq = SIZE(sval); ALLOCATE(val(nq))
1617	lerr = .FALSE.; DO iq=1, nq; READ(sval(iq), *, IOSTAT=ierr) val(iq); lerr = lerr .OR. ierr /= 0; END DO
1618	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not a vector of reals', modname, lerr), lerr)) RETURN
1619	END FUNCTION getKeyByName_r1m
1620	!==============================================================================================================================
1621	LOGICAL FUNCTION getKeyByName_rm(keyn, val, tname, ky, nam) RESULT(lerr)
1622	CHARACTER(LEN=*), INTENT(IN) :: keyn
1623	REAL, ALLOCATABLE, INTENT(OUT) :: val(:)
1624	CHARACTER(LEN=*), INTENT(IN) :: tname(:)
1625	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1626	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1627	!------------------------------------------------------------------------------------------------------------------------------
1628	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:)
1629	INTEGER :: ierr, iq, nq
1630	IF(test(getKeyByName_sm(keyn, sval, tname, ky, names), lerr)) RETURN
1631	nq = SIZE(sval); ALLOCATE(val(nq))
1632	DO iq = 1, nq !--- CONVERT THE KEYS TO INTEGERS
1633	READ(sval(iq), *, IOSTAT=ierr) val(iq)
1634	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not a real', modname, ierr/=0), lerr)) RETURN
1635	END DO
1636	IF(PRESENT(nam)) nam = names
1637	END FUNCTION getKeyByName_rm
1638	!==============================================================================================================================
1639	LOGICAL FUNCTION getKey_rm(keyn, val, ky, nam) RESULT(lerr)
1640	CHARACTER(LEN=*), INTENT(IN) :: keyn
1641	REAL, ALLOCATABLE, INTENT(OUT) :: val(:)
1642	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1643	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1644	!------------------------------------------------------------------------------------------------------------------------------
1645	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:)
1646	INTEGER :: ierr, iq, nq
1647	IF(test(getKey_sm(keyn, sval, ky, names), lerr)) RETURN
1648	nq = SIZE(sval); ALLOCATE(val(nq))
1649	DO iq = 1, nq !--- CONVERT THE KEYS TO INTEGERS
1650	READ(sval(iq), *, IOSTAT=ierr) val(iq)
1651	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not a real', modname, ierr/=0), lerr)) RETURN
1652	END DO
1653	IF(PRESENT(nam)) nam = names
1654	END FUNCTION getKey_rm
1655	!==============================================================================================================================
1656	LOGICAL FUNCTION getKeyByName_l1(keyn, val, tname, ky) RESULT(lerr)
1657	USE strings_mod, ONLY: str2bool
1658	CHARACTER(LEN=*), INTENT(IN) :: keyn
1659	LOGICAL, INTENT(OUT) :: val
1660	CHARACTER(LEN=*), INTENT(IN) :: tname
1661	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1662	!------------------------------------------------------------------------------------------------------------------------------
1663	CHARACTER(LEN=maxlen) :: sval
1664	INTEGER :: ierr
1665	lerr = getKeyByName_s1(keyn, sval, tname, ky)
1666	IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tname)//'" is missing', modname, lerr), lerr)) RETURN
1667	val = str2bool(sval)
1668	END FUNCTION getKeyByName_l1
1669	!==============================================================================================================================
1670	LOGICAL FUNCTION getKeyByName_l1m(keyn, val, tname, ky) RESULT(lerr)
1671	USE strings_mod, ONLY: str2bool
1672	CHARACTER(LEN=*), INTENT(IN) :: keyn
1673	LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:)
1674	CHARACTER(LEN=*), INTENT(IN) :: tname
1675	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1676	!------------------------------------------------------------------------------------------------------------------------------
1677	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:)
1678	INTEGER :: ierr, iq, nq
1679	IF(test(getKeyByName_s1m(keyn, sval, tname, ky), lerr)) RETURN
1680	nq = SIZE(sval); ALLOCATE(val(nq))
1681	lerr = .FALSE.; DO iq=1, nq; val(iq)=str2bool(sval(iq)); END DO
1682	END FUNCTION getKeyByName_l1m
1683	!==============================================================================================================================
1684	LOGICAL FUNCTION getKeyByName_lm(keyn, val, tname, ky, nam) RESULT(lerr)
1685	USE strings_mod, ONLY: str2bool
1686	CHARACTER(LEN=*), INTENT(IN) :: keyn
1687	LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:)
1688	CHARACTER(LEN=*), INTENT(IN) :: tname(:)
1689	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1690	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1691	!------------------------------------------------------------------------------------------------------------------------------
1692	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:)
1693	INTEGER :: ierr, iq, nq
1694	IF(test(getKeyByName_sm(keyn, sval, tname, ky, nam), lerr)) RETURN
1695	nq = SIZE(sval); ALLOCATE(val(nq))
1696	lerr = .FALSE.; DO iq=1, nq; val(iq)=str2bool(sval(iq)); END DO
1697	END FUNCTION getKeyByName_lm
1698	!==============================================================================================================================
1699	LOGICAL FUNCTION getKey_lm(keyn, val, ky, nam) RESULT(lerr)
1700	USE strings_mod, ONLY: str2bool
1701	CHARACTER(LEN=*), INTENT(IN) :: keyn
1702	LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:)
1703	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1704	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1705	!------------------------------------------------------------------------------------------------------------------------------
1706	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:)
1707	INTEGER :: ierr, iq, nq
1708	IF(test(getKey_sm(keyn, sval, ky, nam), lerr)) RETURN
1709	nq = SIZE(sval); ALLOCATE(val(nq))
1710	lerr = .FALSE.; DO iq=1, nq; val(iq)=str2bool(sval(iq)); END DO
1711	END FUNCTION getKey_lm
1712	!==============================================================================================================================
1713
1714
1715	!==============================================================================================================================
1716	!=== ROUTINES TO GET OR PUT TRACERS AND ISOTOPES DATABASES, SINCE tracers AND isotopes ARE PRIVATE VARIABLES ==================
1717	!==============================================================================================================================
1718	SUBROUTINE setKeysDBase(tracers_, isotopes_, isotope_)
1719	TYPE(trac_type), OPTIONAL, INTENT(IN) :: tracers_(:)
1720	TYPE(isot_type), OPTIONAL, INTENT(IN) :: isotopes_(:)
1721	TYPE(isot_type), OPTIONAL, INTENT(IN) :: isotope_
1722	!------------------------------------------------------------------------------------------------------------------------------
1723	TYPE(isot_type), ALLOCATABLE :: iso(:)
1724	INTEGER :: ix, nbIso
1725	IF(PRESENT( tracers_)) THEN; tracers = tracers_; ELSE; ALLOCATE( tracers(0)); END IF
1726	IF(PRESENT(isotopes_)) THEN; isotopes = isotopes_; ELSE; ALLOCATE(isotopes(0)); END IF
1727	IF(PRESENT(isotope_ )) THEN
1728	ix = strIdx(isotopes(:)%parent, isotope_%parent)
1729	IF(ix /= 0) THEN
1730	isotopes(ix) = isotope_
1731	ELSE
1732	nbIso = SIZE(isotopes); ALLOCATE(iso(nbIso+1)); iso(1:nbIso) = isotopes; iso(nbIso+1) = isotope_
1733	CALL MOVE_ALLOC(FROM=iso, TO=isotopes)
1734	END IF
1735	END IF
1736	END SUBROUTINE setKeysDBase
1737	!==============================================================================================================================
1738	SUBROUTINE getKeysDBase(tracers_, isotopes_, isotope_)
1739	TYPE(trac_type), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: tracers_(:)
1740	TYPE(isot_type), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: isotopes_(:)
1741	TYPE(isot_type), OPTIONAL, INTENT(OUT) :: isotope_
1742	!------------------------------------------------------------------------------------------------------------------------------
1743	INTEGER :: ix
1744	IF(PRESENT( tracers_)) THEN; tracers_ = tracers; ELSE; ALLOCATE( tracers_(0)); END IF
1745	IF(PRESENT(isotopes_)) THEN; isotopes_ = isotopes; ELSE; ALLOCATE(isotopes_(0)); END IF
1746	IF(PRESENT(isotope_ )) THEN; ix = strIdx(isotopes(:)%parent, isotope%parent); IF(ix /= 0) isotope_=isotopes(ix); END IF
1747	END SUBROUTINE getKeysDBase
1748	!==============================================================================================================================
1749
1750
1751	!==============================================================================================================================
1752	!=== REMOVE, IF ANY, OR ADD THE PHASE SUFFIX OF THE TRACER NAMED "s" ==========================================================
1753	!==============================================================================================================================
1754	ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION delPhase(s) RESULT(out)
1755	CHARACTER(LEN=*), INTENT(IN) :: s
1756	!------------------------------------------------------------------------------------------------------------------------------
1757	INTEGER :: ix, ip, ns
1758	out = s; ns = LEN_TRIM(s)
1759	IF(s == '') RETURN !--- Empty string: nothing to do
1760	IF(s(1:3)=='H2O' .AND. INDEX(old_phases,s(4:4))/=0 .AND. (ns==4 .OR. s(5:5)=='_')) THEN
1761	out='H2O'//s(5:ns) !--- H2O<phase>[_<iso>][_<tag>]
1762	ELSE IF(s(ns-1:ns-1)==phases_sep .AND. INDEX(known_phases,s(ns:ns))/=0) THEN
1763	out = s(1:ns-2); RETURN !--- <var><phase_sep><phase>
1764	ELSE; DO ip = 1, nphases; ix = INDEX(s, phases_sep//known_phases(ip:ip)//'_'); IF(ix /= 0) EXIT; END DO
1765	IF(ip /= nphases+1) out = s(1:ix-1)//s(ix+2:ns) !--- <var><phase_sep><phase>_<tag>
1766	END IF
1767	END FUNCTION delPhase
1768	!==============================================================================================================================
1769	CHARACTER(LEN=maxlen) FUNCTION addPhase_s1(s,pha) RESULT(out)
1770	CHARACTER(LEN=*), INTENT(IN) :: s
1771	CHARACTER(LEN=1), INTENT(IN) :: pha
1772	!------------------------------------------------------------------------------------------------------------------------------
1773	INTEGER :: l, i
1774	out = s
1775	IF(s == '') RETURN !--- Empty string: nothing to do
1776	i = INDEX(s, '_') !--- /=0 for <var>_<tag> tracers names
1777	l = LEN_TRIM(s)
1778	IF(i == 0) out = TRIM(s)//phases_sep//pha !--- <var> => return <var><sep><pha>
1779	IF(i /= 0) out = s(1:i-1)//phases_sep//pha//'_'//s(i+1:l) !--- <var>_<tag> => return <var><sep><pha>_<tag>
1780	END FUNCTION addPhase_s1
1781	!==============================================================================================================================
1782	FUNCTION addPhase_sm(s,pha) RESULT(out)
1783	CHARACTER(LEN=*), INTENT(IN) :: s(:)
1784	CHARACTER(LEN=1), INTENT(IN) :: pha
1785	CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:)
1786	!------------------------------------------------------------------------------------------------------------------------------
1787	INTEGER :: k
1788	out = [( addPhase_s1(s(k), pha), k=1, SIZE(s) )]
1789	END FUNCTION addPhase_sm
1790	!==============================================================================================================================
1791	CHARACTER(LEN=maxlen) FUNCTION addPhase_i1(s,ipha,phases) RESULT(out)
1792	CHARACTER(LEN=*), INTENT(IN) :: s
1793	INTEGER, INTENT(IN) :: ipha
1794	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases
1795	!------------------------------------------------------------------------------------------------------------------------------
1796	out = s
1797	IF(s == '') RETURN !--- Empty string: nothing to do
1798	IF(ipha == 0 .OR. ipha > nphases) RETURN !--- Absurd index: no phase to add
1799	IF( PRESENT(phases)) out = addPhase_s1(s, phases(ipha:ipha))
1800	IF(.NOT.PRESENT(phases)) out = addPhase_s1(s, known_phases(ipha:ipha))
1801	END FUNCTION addPhase_i1
1802	!==============================================================================================================================
1803	FUNCTION addPhase_im(s,ipha,phases) RESULT(out)
1804	CHARACTER(LEN=*), INTENT(IN) :: s(:)
1805	INTEGER, INTENT(IN) :: ipha
1806	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases
1807	CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:)
1808	!------------------------------------------------------------------------------------------------------------------------------
1809	INTEGER :: k
1810	IF( PRESENT(phases)) out = [( addPhase_i1(s(k), ipha, phases), k=1, SIZE(s) )]
1811	IF(.NOT.PRESENT(phases)) out = [( addPhase_i1(s(k), ipha, known_phases), k=1, SIZE(s) )]
1812	END FUNCTION addPhase_im
1813	!==============================================================================================================================
1814
1815
1816	!==============================================================================================================================
1817	!=== GET PHASE INDEX IN THE POSSIBLE PHASES LIST OR IN A SPECIFIED LIST ("phases") ============================================
1818	!==============================================================================================================================
1819	INTEGER FUNCTION getiPhase(tname, phases) RESULT(iPhase)
1820	CHARACTER(LEN=*), INTENT(IN) :: tname
1821	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases
1822	!------------------------------------------------------------------------------------------------------------------------------
1823	CHARACTER(LEN=maxlen) :: phase
1824	IF( PRESENT(phases)) phase = getPhase(tname, phases, iPhase)
1825	IF(.NOT.PRESENT(phases)) phase = getPhase(tname, known_phases, iPhase)
1826	END FUNCTION getiPhase
1827	!==============================================================================================================================
1828	CHARACTER(LEN=1) FUNCTION getPhase(tname, phases, iPhase) RESULT(phase)
1829	CHARACTER(LEN=*), INTENT(IN) :: tname
1830	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases
1831	INTEGER, OPTIONAL, INTENT(OUT) :: iPhase
1832	!------------------------------------------------------------------------------------------------------------------------------
1833	INTEGER :: ip
1834	phase = TRIM(strHead(strTail(tname, phases_sep, .TRUE.), '_', .TRUE.))
1835	IF( PRESENT(phases)) ip = INDEX( phases, phase)
1836	IF(.NOT.PRESENT(phases)) ip = INDEX(known_phases, phase)
1837	IF(ip == 0) phase = 'g'
1838	IF(PRESENT(iPhase)) iPhase = ip
1839	END FUNCTION getPhase
1840	!==============================================================================================================================
1841
1842
1843	!==============================================================================================================================
1844	!============ CONVERT WATER-DERIVED NAMES FROM FORMER TO CURRENT CONVENTION ; OTHER NAMES ARE LEFT UNTOUCHED ==================
1845	!======= NAMES STRUCTURE: H2O[<phase>][_<isotope>][_<tag>] (<phase> from "old_phases", <isotope> from "oldH2OIso") ============
1846	!==============================================================================================================================
1847	CHARACTER(LEN=maxlen) FUNCTION old2newH2O_1(oldName, iPhase) RESULT(newName)
1848	CHARACTER(LEN=*), INTENT(IN) :: oldName
1849	INTEGER, OPTIONAL, INTENT(OUT) :: iPhase
1850	!------------------------------------------------------------------------------------------------------------------------------
1851	CHARACTER(LEN=maxlen), ALLOCATABLE :: tmp(:)
1852	INTEGER :: ix, ip, nt
1853	LOGICAL :: lerr
1854	newName = oldName
1855	IF(PRESENT(iPhase)) iPhase = 1 !--- Default: gaseous phase
1856	lerr = strParse(oldName, '_', tmp, n=nt) !--- Parsing: 1 up to 3 elements.
1857	ip = strIdx( [('H2O'//old_phases(ix:ix), ix=1, nphases)], tmp(1) ) !--- Phase index
1858	IF(ip /= 0 .AND. PRESENT(iPhase)) iPhase = ip !--- Returning phase index
1859	IF(ip == 0 .AND. tmp(1) /= 'H2O') RETURN !--- Not an old-style water-related species
1860	IF(nt == 1) THEN
1861	newName = addPhase('H2O',ip) !=== WATER WITH OR WITHOUT PHASE
1862	ELSE
1863	ix = strIdx(oldH2OIso, tmp(2)) !--- Index in the known isotopes list
1864	IF(ix /= 0) tmp(2) = newH2OIso(ix) !--- Move to new isotope name
1865	IF(ip /= 0) tmp(2) = addPhase(tmp(2), ip) !--- Add phase to isotope name
1866	newName = TRIM(strStack(tmp(2:nt), '_')) !=== WATER ISOTOPE OR TAGGING TRACER
1867	END IF
1868	END FUNCTION old2newH2O_1
1869	!==============================================================================================================================
1870	FUNCTION old2newH2O_m(oldName) RESULT(newName)
1871	CHARACTER(LEN=*), INTENT(IN) :: oldName(:)
1872	CHARACTER(LEN=maxlen) :: newName(SIZE(oldName))
1873	!------------------------------------------------------------------------------------------------------------------------------
1874	INTEGER :: i
1875	newName = [(old2newH2O_1(oldName(i)), i=1, SIZE(oldName))]
1876	END FUNCTION old2newH2O_m
1877	!==============================================================================================================================
1878
1879
1880	!==============================================================================================================================
1881	!============ CONVERT WATER-DERIVED NAMES FROM CURRENT TO FORMER CONVENTION ; OTHER NAMES ARE LEFT UNTOUCHED ==================
1882	!==== NAMES STRUCTURE: <var>[<phase_sep><phase>][_<tag>] (<phase> from "known_phases", <var> = 'H2O' or from "newH2OIso") =====
1883	!==============================================================================================================================
1884	CHARACTER(LEN=maxlen) FUNCTION new2oldH2O_1(newName, iPhase) RESULT(oldName)
1885	CHARACTER(LEN=*), INTENT(IN) :: newName
1886	INTEGER, OPTIONAL, INTENT(OUT) :: iPhase
1887	!------------------------------------------------------------------------------------------------------------------------------
1888	CHARACTER(LEN=maxlen), ALLOCATABLE :: tmp(:)
1889	INTEGER :: ix, ip
1890	CHARACTER(LEN=maxlen) :: var
1891	oldName = newName
1892	IF(PRESENT(iPhase)) iPhase = 1 !--- Default: gaseous phase
1893	ip = getiPhase(newName) !--- Phase index
1894	IF(ip /= 0 .AND. PRESENT(iPhase)) iPhase = ip !--- Returning phase index
1895	ix = strIdx(newH2OIso, newName) !--- Index in the known H2O isotopes list
1896	IF(ix /= 0) oldName = 'H2O'//'_'//TRIM(oldH2OIso(ix)) !=== WATER ISOTOPE WITHOUT PHASE
1897	IF(ix /= 0 .OR. ip == 0) RETURN
1898	oldName = 'H2O'//old_phases(ip:ip)
1899	IF(newName == addPhase('H2O', ip)) RETURN !=== WATER WITH PHASE
1900	var = TRIM(strHead(newName, phases_sep, .TRUE.)) !--- Head variable name (no phase)
1901	ix = strIdx(newH2OIso, var) !--- Index in the known H2O isotopes list
1902	IF(ix == 0) RETURN !=== H2O[vli]_<var> (<var> /= H2O isotope)
1903	oldName = TRIM(oldName)//'_'//TRIM(oldH2OIso(ix)) !=== WATER ISOTOPE WITH PHASE
1904	var = addPhase(var, ip) !--- Head variable with phase
1905	IF(newName /= var) oldName = TRIM(oldName)//strTail(newName, TRIM(var)) !=== WATER ISOTOPIC TAGGING TRACER
1906	END FUNCTION new2oldH2O_1
1907	!==============================================================================================================================
1908	FUNCTION new2oldH2O_m(newName) RESULT(oldName)
1909	CHARACTER(LEN=*), INTENT(IN) :: newName(:)
1910	CHARACTER(LEN=maxlen) :: oldName(SIZE(newName))
1911	!------------------------------------------------------------------------------------------------------------------------------
1912	INTEGER :: i
1913	oldName = [(new2oldH2O_1(newName(i)), i=1, SIZE(newName))]
1914	END FUNCTION new2oldH2O_m
1915	!==============================================================================================================================
1916
1917
1918	!==============================================================================================================================
1919	!=== GET THE NAME(S) OF THE ANCESTOR(S) OF TRACER(S) "tname" AT GENERATION "igen" IN THE TRACERS DESCRIPTORS LIST "tr" =======
1920	!==============================================================================================================================
1921	SUBROUTINE ancestor_1(t, out, tname, igen)
1922	TYPE(trac_type), INTENT(IN) :: t(:)
1923	CHARACTER(LEN=maxlen), INTENT(OUT) :: out
1924	CHARACTER(LEN=*), INTENT(IN) :: tname
1925	INTEGER, OPTIONAL, INTENT(IN) :: igen
1926	!------------------------------------------------------------------------------------------------------------------------------
1927	INTEGER :: ix
1928	CALL idxAncestor_1(t, ix, tname, igen)
1929	out = ''; IF(ix /= 0) out = t(ix)%name
1930	END SUBROUTINE ancestor_1
1931	!==============================================================================================================================
1932	SUBROUTINE ancestor_mt(t, out, tname, igen)
1933	TYPE(trac_type), INTENT(IN) :: t(:)
1934	CHARACTER(LEN=*), INTENT(IN) :: tname(:)
1935	CHARACTER(LEN=maxlen), INTENT(OUT) :: out(SIZE(tname))
1936	INTEGER, OPTIONAL, INTENT(IN) :: igen
1937	!------------------------------------------------------------------------------------------------------------------------------
1938	INTEGER :: ix(SIZE(tname))
1939	CALL idxAncestor_mt(t, ix, tname, igen)
1940	out(:) = ''; WHERE(ix /= 0) out = t(ix)%name
1941	END SUBROUTINE ancestor_mt
1942	!==============================================================================================================================
1943	SUBROUTINE ancestor_m(t, out, igen)
1944	TYPE(trac_type), INTENT(IN) :: t(:)
1945	CHARACTER(LEN=maxlen), INTENT(OUT) :: out(SIZE(t))
1946	INTEGER, OPTIONAL, INTENT(IN) :: igen
1947	!------------------------------------------------------------------------------------------------------------------------------
1948	INTEGER :: ix(SIZE(t))
1949	CALL idxAncestor_m(t, ix, igen)
1950	out(:) = ''; WHERE(ix /= 0) out = t(ix)%name
1951	END SUBROUTINE ancestor_m
1952	!==============================================================================================================================
1953
1954
1955	!==============================================================================================================================
1956	!=== GET THE INDEX(ES) OF THE GENERATION "igen" ANCESTOR(S) OF "tname" (t%name IF UNSPECIFIED) IN THE "t" LIST ================
1957	!==============================================================================================================================
1958	SUBROUTINE idxAncestor_1(t, idx, tname, igen)
1959	TYPE(trac_type), INTENT(IN) :: t(:)
1960	INTEGER, INTENT(OUT) :: idx
1961	CHARACTER(LEN=*), INTENT(IN) :: tname
1962	INTEGER, OPTIONAL, INTENT(IN) :: igen
1963	INTEGER :: ig
1964	ig = 0; IF(PRESENT(igen)) ig = igen
1965	idx = strIdx(t(:)%name, tname)
1966	IF(idx == 0) RETURN !--- Tracer not found
1967	IF(t(idx)%iGeneration <= ig) RETURN !--- Tracer has a lower generation number than asked generation 'igen"
1968	DO WHILE(t(idx)%iGeneration > ig); idx = strIdx(t(:)%name, t(idx)%parent); END DO
1969	END SUBROUTINE idxAncestor_1
1970	!------------------------------------------------------------------------------------------------------------------------------
1971	SUBROUTINE idxAncestor_mt(t, idx, tname, igen)
1972	TYPE(trac_type), INTENT(IN) :: t(:)
1973	CHARACTER(LEN=*), INTENT(IN) :: tname(:)
1974	INTEGER, INTENT(OUT) :: idx(SIZE(tname))
1975	INTEGER, OPTIONAL, INTENT(IN) :: igen
1976	INTEGER :: ix
1977	DO ix = 1, SIZE(tname); CALL idxAncestor_1(t, idx(ix), tname(ix), igen); END DO
1978	END SUBROUTINE idxAncestor_mt
1979	!------------------------------------------------------------------------------------------------------------------------------
1980	SUBROUTINE idxAncestor_m(t, idx, igen)
1981	TYPE(trac_type), INTENT(IN) :: t(:)
1982	INTEGER, INTENT(OUT) :: idx(SIZE(t))
1983	INTEGER, OPTIONAL, INTENT(IN) :: igen
1984	INTEGER :: ix
1985	DO ix = 1, SIZE(t); CALL idxAncestor_1(t, idx(ix), t(ix)%name, igen); END DO
1986	END SUBROUTINE idxAncestor_m
1987	!==============================================================================================================================
1988
1989
1990	END MODULE readTracFiles_mod
1991

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

Download in other formats:

Original Format