Context Navigation

readTracFiles_mod.f90 @ 4334

Last change on this file since 4334 was 4334, checked in by dcugnet, 23 months ago
Fix the traceur.def backward compatibility issue.
File size: 130.1 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(jq))
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	END SUBROUTINE indexUpdate
1022	!==============================================================================================================================
1023
1024
1025	!==============================================================================================================================
1026	!=== READ FILE "fnam" TO APPEND THE "dBase" TRACERS DATABASE WITH AS MUCH SECTIONS AS PARENTS NAMES IN "isot(:)%parent": ====
1027	!=== * Each section dBase(i)%name contains the isotopes "dBase(i)%trac(:)" descending on "dBase(i)%name"="iso(i)%parent" ====
1028	!=== * For each isotopes class, the <key>=<val> vector of each tracer is moved into the isotopes descriptor "isot" ====
1029	!=== NOTES: ====
1030	!=== * Most of the "isot" components have been defined in the calling routine (readIsotopes): ====
1031	!=== parent, nzone, zone(:), niso, keys(:)%name, ntiso, trac(:), nphas, phas, iqIsoPha(:,:), itZonPhi(:,:) ====
1032	!=== * Same syntax for isotopes file and "tracer.def": a tracers section contains one line for each of its isotopes ====
1033	!=== * Each tracers section can contain a "params" virtual isotope line of isotopes parameters default values ====
1034	!=== * In case keys are found both in the "params" section and the "*.def" file, the later value is retained ====
1035	!=== * On each isotope line, defined keys can be used for other keys defintions (single level depth substitution) ====
1036	!=== * The routine gives an error if a required isotope is not available in the database stored in "fnam" ====
1037	!==============================================================================================================================
1038	LOGICAL FUNCTION readIsotopesFile_prv(fnam, isot) RESULT(lerr)
1039	CHARACTER(LEN=*), INTENT(IN) :: fnam !--- Input file name
1040	TYPE(isot_type), TARGET, INTENT(INOUT) :: isot(:) !--- Isotopes descriptors (field %parent must be defined!)
1041	INTEGER :: ik, is, it, idb, nk0, i, iis
1042	INTEGER :: nk, ns, nt, ndb, nb0, i0
1043	CHARACTER(LEN=maxlen), POINTER :: k(:), v(:), k0(:), v0(:)
1044	CHARACTER(LEN=maxlen), ALLOCATABLE :: vals(:)
1045	CHARACTER(LEN=maxlen) :: val, modname
1046	TYPE(keys_type), POINTER :: ky(:)
1047	TYPE(trac_type), POINTER :: tt(:), t
1048	TYPE(dataBase_type), ALLOCATABLE :: tdb(:)
1049	modname = 'readIsotopesFile'
1050
1051	!--- THE INPUT FILE MUST BE PRESENT
1052	IF(test(fmsg('Missing isotopes parameters file "'//TRIM(fnam)//'"', modname, testFile(fnam)),lerr)) RETURN
1053
1054	!--- READ THE FILE SECTIONS, ONE EACH PARENT TRACER
1055	nb0 = SIZE(dBase, DIM=1)+1 !--- Next database element index
1056	IF(test(readSections(fnam,strStack(isot(:)%parent,'\|')),lerr)) RETURN !--- Read sections, one each parent tracer
1057	ndb = SIZE(dBase, DIM=1) !--- Current database size
1058	DO idb = nb0, ndb
1059	iis = idb-nb0+1
1060
1061	!--- GET FEW GLOBAL KEYS FROM "def" FILES AND ADD THEM TO THE 'params' SECTION
1062	CALL addKeysFromDef(dBase(idb)%trac, 'params')
1063
1064	!--- SUBSTITUTE THE KEYS DEFINED IN THE 'params' VIRTUAL TRACER ; SUBSTITUTE LOCAL KEYS ; REMOVE 'params' VIRTUAL TRACER
1065	CALL subDefault(dBase(idb)%trac, 'params', .TRUE.)
1066
1067	tt => dBase(idb)%trac
1068
1069	!--- REDUCE THE EXPRESSIONS TO OBTAIN SCALARS AND TRANSFER THEM TO THE "isot" ISOTOPES DESCRIPTORS VECTOR
1070	DO it = 1, SIZE(dBase(idb)%trac)
1071	t => dBase(idb)%trac(it)
1072	is = strIdx(isot(iis)%keys(:)%name, t%name) !--- Index in "isot(iis)%keys(:)%name" of isotope "t%name"
1073	IF(is == 0) CYCLE
1074	IF(test(ANY(reduceExpr(t%keys%val, vals)), lerr)) RETURN !--- Reduce expressions ; detect non-numerical elements
1075	isot(iis)%keys(is)%key = t%keys%key
1076	isot(iis)%keys(is)%val = vals
1077	END DO
1078
1079	!--- CHECK FOR MISSING ISOTOPES (NO KEYS ALLOCATED)
1080	IF(test(checkList(isot(iis)%keys(:)%name, .NOT.[( ALLOCATED(isot(iis)%keys(is)%key), is=1, SIZE(isot(iis)%keys) )], &
1081	'Check file "'//TRIM(fnam)//'" in section "'//TRIM(dBase(idb)%name)//'"', 'isotopes', 'missing'), lerr)) RETURN
1082	END DO
1083
1084	!--- CLEAN THE DATABASE ENTRIES
1085	IF(nb0 == 1) THEN
1086	DEALLOCATE(dBase); ALLOCATE(dBase(0))
1087	ELSE
1088	ALLOCATE(tdb(nb0-1)); tdb(1:nb0-1)=dBase(1:nb0-1); CALL MOVE_ALLOC(FROM=tdb, TO=dBase)
1089	END IF
1090
1091	!--- GET THE isoCheck ENTRY FROM THE *.DEF FILES (MIGHT BE CHANGED TO A CLASS-DEPENDANT KEYWORD)
1092	CALL get_in('ok_iso_verif', isot(strIdx(isot%parent, 'H2O'))%check, .FALSE.)
1093
1094	lerr = dispIsotopes()
1095
1096	CONTAINS
1097
1098	!------------------------------------------------------------------------------------------------------------------------------
1099	LOGICAL FUNCTION dispIsotopes() RESULT(lerr)
1100	INTEGER :: ik, nk, ip, it, nt
1101	CHARACTER(LEN=maxlen) :: prf
1102	CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:), val(:,:)
1103	CALL msg('Isotopes parameters read from file "'//TRIM(fnam)//'":', modname)
1104	DO ip = 1, SIZE(isot) !--- Loop on parents tracers
1105	nk = SIZE(isot(ip)%keys(1)%key) !--- Same keys for each isotope
1106	nt = SIZE(isot(ip)%keys) !--- Number of isotopes
1107	prf = 'i'//REPEAT('s',nk+1) !--- Profile for table printing
1108	ALLOCATE(ttl(nk+2), val(nt,nk+1))
1109	ttl(1:2) = ['it ','name']; ttl(3:nk+2) = isot(ip)%keys(1)%key(:)!--- Titles line with keys names
1110	val(:,1) = isot(ip)%keys(:)%name !--- Values table 1st column: isotopes names
1111	DO ik = 1, nk
1112	DO it = 1, nt
1113	val(it,ik+1) = isot(ip)%keys(it)%val(ik) !--- Other columns: keys values
1114	END DO
1115	END DO
1116	IF(test(fmsg('Problem with the table content', modname, dispTable(prf, ttl, val, &
1117	cat([(it,it=1,nt)]), rFmt='(EN8.4)', nColMax=maxTableWidth, nHead=2, sub=modname)), lerr)) RETURN
1118	DEALLOCATE(ttl, val)
1119	END DO
1120	END FUNCTION dispIsotopes
1121	!------------------------------------------------------------------------------------------------------------------------------
1122
1123	END FUNCTION readIsotopesFile_prv
1124	!==============================================================================================================================
1125
1126
1127	!==============================================================================================================================
1128	!=== IF ISOTOPES (2ND GENERATION TRACERS) ARE DETECTED: ===
1129	!=== * COMPUTE MOST OF THE RELATED QUANTITIES ("isot" COMPONENTS). ===
1130	!=== * COMPUTE FEW ISOTOPES-DEDICATED "trac" COMPONENTS ===
1131	!=== * CALL readIsotopesFile_prv TO GET PHYSICAL QUANTITIES (<key>=<val> PAIRS) ===
1132	!=== NOTE: THIS IS DONE HERE (IN A ROUTINE CALLED BY THE DYNAMIC), BECAUSE THE DYNAMIC NEEDS FEW PHYSICAL PARAMETERS. ===
1133	!==============================================================================================================================
1134	LOGICAL FUNCTION readIsotopesFile(iNames) RESULT(lerr)
1135	CHARACTER(LEN=maxlen), TARGET, OPTIONAL, INTENT(IN) :: iNames(:)
1136	CHARACTER(LEN=maxlen), ALLOCATABLE :: p(:), str(:) !--- Temporary storage
1137	CHARACTER(LEN=maxlen) :: iName, modname
1138	CHARACTER(LEN=1) :: ph !--- Phase
1139	INTEGER :: ic, ip, iq, it, iz
1140	LOGICAL, ALLOCATABLE :: ll(:) !--- Mask
1141	TYPE(trac_type), POINTER :: t(:), t1
1142	TYPE(isot_type), POINTER :: i
1143	lerr = .FALSE.
1144	modname = 'readIsotopesFile'
1145
1146	t => tracers
1147
1148	!--- GET FROM "tracers" THE FULL LIST OF AVAILABLE ISOTOPES CLASSES
1149	p = PACK(delPhase(t%parent), MASK = t%type=='tracer' .AND. t%iGeneration==1)
1150	CALL strReduce(p, nbIso)
1151
1152	!--- CHECK WHETHER NEEDED ISOTOPES CLASSES "iNames" ARE AVAILABLE OR NOT
1153	IF(PRESENT(iNames)) THEN
1154	DO it = 1, SIZE(iNames)
1155	IF(test(fmsg('No isotopes class "'//TRIM(iNames(it))//'" found among tracers', modname, ALL(p /= iNames(it))), lerr)) RETURN
1156	END DO
1157	p = iNames; nbIso = SIZE(p)
1158	END IF
1159	IF(ALLOCATED(isotopes)) DEALLOCATE(isotopes)
1160	ALLOCATE(isotopes(nbIso))
1161
1162	IF(nbIso==0) RETURN !=== NO ISOTOPES: FINISHED
1163
1164	!--- ISOTOPES RELATED VARIABLES ; NULL OR EMPTY IF NO ISOTOPES
1165	isotopes(:)%parent = p
1166	DO ic = 1, SIZE(p) !--- Loop on isotopes classes
1167	i => isotopes(ic)
1168	iname = i%parent !--- Current isotopes class name (parent tracer name)
1169
1170	!=== Isotopes children of tracer "iname": mask, names, number (same for each phase of "iname")
1171	ll = t(:)%type=='tracer' .AND. delPhase(t(:)%parent) == iname .AND. t(:)%phase == 'g'
1172	str = PACK(delPhase(t(:)%name), MASK = ll) !--- Effectively found isotopes of "iname"
1173	i%niso = SIZE(str) !--- Number of "effectively found isotopes of "iname"
1174	ALLOCATE(i%keys(i%niso))
1175	FORALL(it = 1:i%niso) i%keys(it)%name = str(it)
1176
1177	!=== Geographic tagging tracers descending on tracer "iname": mask, names, number
1178	ll = t(:)%type=='tag' .AND. delPhase(t(:)%gen0Name) == iname .AND. t(:)%iGeneration == 2
1179	i%zone = PACK(strTail(t(:)%name,'_'), MASK = ll) !--- Tagging zones names for isotopes category "iname"
1180	CALL strReduce(i%zone)
1181	i%nzone = SIZE(i%zone) !--- Tagging zones number for isotopes category "iname"
1182
1183	!=== Geographic tracers of the isotopes children of tracer "iname" (same for each phase of "iname")
1184	! NOTE: One might like to create a similar variable for 2nd generation tagging tracers (tagging the gen1 tracers)
1185	str = PACK(delPhase(t(:)%name), MASK=ll)
1186	CALL strReduce(str)
1187	i%ntiso = i%niso + SIZE(str) !--- Number of isotopes + their geographic tracers [ntiso]
1188	ALLOCATE(i%trac(i%ntiso))
1189	FORALL(it = 1:i%niso) i%trac(it) = i%keys(it)%name
1190	FORALL(it = i%niso+1:i%ntiso) i%trac(it) = str(it-i%niso)
1191
1192	!=== Phases for tracer "iname"
1193	i%phase = ''
1194	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
1195	i%nphas = LEN_TRIM(i%phase) !--- Equal to "nqo" for water
1196
1197	!=== Tables giving the index in a table of effectively found items for each dynamical tracer (1<=iq<=nqtot)
1198	DO iq = 1, SIZE(t)
1199	t1 => tracers(iq)
1200	IF(delPhase(t1%gen0Name)/=iname .OR. t1%iGeneration==0) CYCLE !--- Only deal with tracers descending on "iname"
1201	t1%iso_iGroup = ic !--- Isotopes family idx in list "isotopes(:)%parent"
1202	t1%iso_iName = strIdx(i%trac, delPhase(strHead(t1%name,'_'))) !--- Current isotope idx in effective isotopes list
1203	t1%iso_iZone = strIdx(i%zone, strTail(t1%name,'_') ) !--- Current isotope zone idx in effective zones list
1204	t1%iso_iPhase = INDEX(i%phase,TRIM(t1%phase)) !--- Current isotope phase idx in effective phases list
1205	IF(t1%iGeneration /= 2) t1%iso_iZone = 0 !--- Skip possible generation 1 tagging tracers
1206	END DO
1207
1208	!=== Table used to get iq (index in dyn array, size nqtot) from the isotope and phase indexes ; the full isotopes list
1209	! (including tagging tracers) is sorted this way: iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN
1210	i%iqIsoPha = RESHAPE( [( (strIdx(t%name, addPhase(i%trac(it),i%phase(ip:ip))), it=1, i%ntiso), ip=1, i%nphas)], &
1211	[i%ntiso, i%nphas] )
1212	!=== Table used to get ix (index in tagging tracers isotopes list, size ntiso) from the zone and isotope indexes
1213	i%itZonIso = RESHAPE( [( (strIdx(i%trac(:), TRIM(i%trac(it))//'_'//TRIM(i%zone(iz))), iz=1, i%nzone), it=1, i%niso )], &
1214	[i%nzone, i%niso] )
1215	END DO
1216
1217	!=== READ PHYSICAL PARAMETERS FROM isoFile FILE
1218	IF(test(readIsotopesFile_prv(isoFile, isotopes), lerr)) RETURN
1219
1220	!=== CHECK CONSISTENCY
1221	IF(test(testIsotopes(), lerr)) RETURN
1222
1223	!=== SELECT FIRST ISOTOPES CLASS OR, IF POSSIBLE, WATER CLASS
1224	IF(.NOT.test(isoSelect(1, .TRUE.), lerr)) THEN; IF(isotope%parent == 'H2O') iH2O = ixIso; END IF
1225
1226	CONTAINS
1227
1228	!------------------------------------------------------------------------------------------------------------------------------
1229	LOGICAL FUNCTION testIsotopes() RESULT(lerr) !--- MAKE SURE MEMBERS OF AN ISOTOPES FAMILY ARE PRESENT IN THE SAME PHASES
1230	!------------------------------------------------------------------------------------------------------------------------------
1231	INTEGER :: ix, it, ip, np, iz, nz
1232	TYPE(isot_type), POINTER :: i
1233	DO ix = 1, nbIso
1234	i => isotopes(ix)
1235	!--- Check whether each isotope and tagging isotopic tracer is present in the same number of phases
1236	DO it = 1, i%ntiso
1237	np = SUM([(COUNT(tracers(:)%name == addPhase(i%trac(it), i%phase(ip:ip))), ip=1, i%nphas)])
1238	IF(test(fmsg(TRIM(int2str(np))//' phases instead of '//TRIM(int2str(i%nphas))//' for '//TRIM(i%trac(it)), &
1239	modname, np /= i%nphas), lerr)) RETURN
1240	END DO
1241	DO it = 1, i%niso
1242	nz = SUM([(COUNT(i%trac == TRIM(i%trac(it))//'_'//i%zone(iz)), iz=1, i%nzone)])
1243	IF(test(fmsg(TRIM(int2str(nz))//' tagging zones instead of '//TRIM(int2str(i%nzone))//' for '//TRIM(i%trac(it)), &
1244	modname, nz /= i%nzone), lerr)) RETURN
1245	END DO
1246	END DO
1247	END FUNCTION testIsotopes
1248	!------------------------------------------------------------------------------------------------------------------------------
1249
1250	END FUNCTION readIsotopesFile
1251	!==============================================================================================================================
1252
1253
1254	!==============================================================================================================================
1255	!=== THE ROUTINE isoSelect IS USED TO SWITCH FROM AN ISOTOPE FAMILY TO ANOTHER: ISOTOPES DEPENDENT PARAMETERS ARE UPDATED
1256	! Single generic "isoSelect" routine, using the predefined index of the parent (fast version) or its name (first call).
1257	!==============================================================================================================================
1258	LOGICAL FUNCTION isoSelectByName(iName, lVerbose) RESULT(lerr)
1259	IMPLICIT NONE
1260	CHARACTER(LEN=*), INTENT(IN) :: iName
1261	LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose
1262	INTEGER :: iIso
1263	LOGICAL :: lV
1264	lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose
1265	iIso = strIdx(isotopes(:)%parent, iName)
1266	IF(test(iIso == 0, lerr)) THEN
1267	niso = 0; ntiso = 0; nzone = 0; nphas = 0; isoCheck=.FALSE.
1268	CALL msg('no isotope family named "'//TRIM(iName)//'"', ll=lV)
1269	RETURN
1270	END IF
1271	lerr = isoSelectByIndex(iIso, lV)
1272	END FUNCTION isoSelectByName
1273	!==============================================================================================================================
1274	LOGICAL FUNCTION isoSelectByIndex(iIso, lVerbose) RESULT(lerr)
1275	IMPLICIT NONE
1276	INTEGER, INTENT(IN) :: iIso
1277	LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose
1278	LOGICAL :: lV
1279	lv = .FALSE.; IF(PRESENT(lVerbose)) lv = lVerbose
1280	lerr = .FALSE.
1281	IF(iIso == ixIso) RETURN !--- Nothing to do if the index is already OK
1282	lerr = iIso<=0 .OR. iIso>SIZE(isotopes)
1283	CALL msg('Inconsistent isotopes family index '//TRIM(int2str(iIso))//': should be > 0 and <= '&
1284	//TRIM(int2str(SIZE(isotopes)))//'"', ll = lerr .AND. lV)
1285	IF(lerr) RETURN
1286	ixIso = iIso !--- Update currently selected family index
1287	isotope => isotopes(ixIso) !--- Select corresponding component
1288	isoKeys => isotope%keys; niso = isotope%niso
1289	isoName => isotope%trac; ntiso = isotope%ntiso
1290	isoZone => isotope%zone; nzone = isotope%nzone
1291	isoPhas => isotope%phase; nphas = isotope%nphas
1292	itZonIso => isotope%itZonIso; isoCheck = isotope%check
1293	iqIsoPha => isotope%iqIsoPha
1294	END FUNCTION isoSelectByIndex
1295	!==============================================================================================================================
1296
1297
1298	!==============================================================================================================================
1299	!=== ADD THE <key>=<val> PAIR TO THE "ky[(:)]" KEY[S] DESCRIPTOR[S] OR THE <key>=<val(:)> PAIRS TO THE "ky(:)" KEYS DESCRIPTORS
1300	!==============================================================================================================================
1301	SUBROUTINE addKey_1(key, val, ky, lOverWrite)
1302	CHARACTER(LEN=*), INTENT(IN) :: key, val
1303	TYPE(keys_type), INTENT(INOUT) :: ky
1304	LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite
1305	!------------------------------------------------------------------------------------------------------------------------------
1306	CHARACTER(LEN=maxlen), ALLOCATABLE :: k(:), v(:)
1307	INTEGER :: iky, nky
1308	LOGICAL :: lo
1309	lo=.TRUE.; IF(PRESENT(lOverWrite)) lo=lOverWrite
1310	iky = strIdx(ky%key,key)
1311	IF(iky == 0) THEN
1312	nky = SIZE(ky%key)
1313	ALLOCATE(k(nky+1)); IF(ALLOCATED(ky%key)) k(1:nky) = ky%key; k(nky+1) = key; ky%key = k
1314	ALLOCATE(v(nky+1)); IF(ALLOCATED(ky%val)) v(1:nky) = ky%val; v(nky+1) = val; ky%val = v
1315	ELSE IF(lo) THEN
1316	ky%key(iky) = key; ky%val(iky) = val
1317	END IF
1318	END SUBROUTINE addKey_1
1319	!==============================================================================================================================
1320	SUBROUTINE addKey_m(key, val, ky, lOverWrite)
1321	CHARACTER(LEN=*), INTENT(IN) :: key, val
1322	TYPE(keys_type), INTENT(INOUT) :: ky(:)
1323	LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite
1324	!------------------------------------------------------------------------------------------------------------------------------
1325	INTEGER :: itr
1326	DO itr = 1, SIZE(ky)
1327	CALL addKey_1(key, val, ky(itr), lOverWrite)
1328	END DO
1329	END SUBROUTINE addKey_m
1330	!==============================================================================================================================
1331	SUBROUTINE addKey_mm(key, val, ky, lOverWrite)
1332	CHARACTER(LEN=*), INTENT(IN) :: key, val(:)
1333	TYPE(keys_type), INTENT(INOUT) :: ky(:)
1334	LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite
1335	!------------------------------------------------------------------------------------------------------------------------------
1336	INTEGER :: itr
1337	DO itr = 1, SIZE(ky); CALL addKey_1(key, val(itr), ky(itr), lOverWrite); END DO
1338	END SUBROUTINE addKey_mm
1339	!==============================================================================================================================
1340
1341
1342	!==============================================================================================================================
1343	!=== OVERWRITE THE KEYS OF THE TRACER NAMED "tr0" WITH THE VALUES FOUND IN THE *.def FILES, IF ANY. ===========================
1344	!==============================================================================================================================
1345	SUBROUTINE addKeysFromDef(t, tr0)
1346	TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: t(:)
1347	CHARACTER(LEN=*), INTENT(IN) :: tr0
1348	!------------------------------------------------------------------------------------------------------------------------------
1349	CHARACTER(LEN=maxlen) :: val
1350	INTEGER :: ik, jd
1351	jd = strIdx(t%name, tr0)
1352	IF(jd == 0) RETURN
1353	DO ik = 1, SIZE(t(jd)%keys%key)
1354	CALL get_in(t(jd)%keys%key(ik), val, 'none')
1355	IF(val /= 'none') CALL addKey_1(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.)
1356	END DO
1357	END SUBROUTINE addKeysFromDef
1358	!==============================================================================================================================
1359
1360
1361	!==============================================================================================================================
1362	!=== REMOVE THE KEYS NAMED "keyn(:)" FROM EITHER THE "itr"th OR ALL THE KEYS DESCRIPTORS OF "ky(:)" ===========================
1363	!==============================================================================================================================
1364	SUBROUTINE delKey_1(itr, keyn, ky)
1365	INTEGER, INTENT(IN) :: itr
1366	CHARACTER(LEN=*), INTENT(IN) :: keyn(:)
1367	TYPE(trac_type), INTENT(INOUT) :: ky(:)
1368	!------------------------------------------------------------------------------------------------------------------------------
1369	CHARACTER(LEN=maxlen), ALLOCATABLE :: k(:), v(:)
1370	LOGICAL, ALLOCATABLE :: ll(:)
1371	INTEGER :: iky
1372	IF(itr<=0 .OR. itr>SIZE(ky, DIM=1)) RETURN !--- Index is out of range
1373	ll = [( ALL(keyn/=ky(itr)%keys%key(iky)), iky=1, SIZE(ky(itr)%keys%key) )]
1374	k = PACK(ky(itr)%keys%key, MASK=ll); CALL MOVE_ALLOC(FROM=k, TO=ky(itr)%keys%key)
1375	v = PACK(ky(itr)%keys%val, MASK=ll); CALL MOVE_ALLOC(FROM=v, TO=ky(itr)%keys%val)
1376	END SUBROUTINE delKey_1
1377	!==============================================================================================================================
1378	SUBROUTINE delKey(keyn, ky)
1379	CHARACTER(LEN=*), INTENT(IN) :: keyn(:)
1380	TYPE(trac_type), INTENT(INOUT) :: ky(:)
1381	!------------------------------------------------------------------------------------------------------------------------------
1382	INTEGER :: iky
1383	DO iky = 1, SIZE(ky); CALL delKey_1(iky, keyn, ky); END DO
1384	END SUBROUTINE delKey
1385	!==============================================================================================================================
1386
1387
1388	!==============================================================================================================================
1389	!================ GET THE VALUE OF A KEY FROM A "keys_type" DERIVED TYPE ; THE RESULT IS THE RETURNED VALUE ===================
1390	!==============================================================================================================================
1391	CHARACTER(LEN=maxlen) FUNCTION fgetKeyIdx_s1(itr, keyn, ky, def_val, lerr) RESULT(val)
1392	INTEGER, INTENT(IN) :: itr
1393	CHARACTER(LEN=*), INTENT(IN) :: keyn
1394	TYPE(keys_type), INTENT(IN) :: ky(:)
1395	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def_val
1396	LOGICAL, OPTIONAL, INTENT(OUT) :: lerr
1397	!------------------------------------------------------------------------------------------------------------------------------
1398	INTEGER :: iky
1399	LOGICAL :: ler
1400	iky = 0; val = ''
1401	IF(.NOT.test(itr <= 0 .OR. itr > SIZE(ky), ler)) iky = strIdx(ky(itr)%key(:), keyn) !--- Correct index
1402	IF(.NOT.test(iky == 0, ler)) val = ky(itr)%val(iky) !--- Found key
1403	IF(iky == 0) THEN
1404	IF(.NOT.test(.NOT.PRESENT(def_val), ler)) val = def_val !--- Default value
1405	END IF
1406	IF(PRESENT(lerr)) lerr = ler
1407	END FUNCTION fgetKeyIdx_s1
1408	!==============================================================================================================================
1409	CHARACTER(LEN=maxlen) FUNCTION fgetKeyNam_s1(tname, keyn, ky, def_val, lerr) RESULT(val)
1410	CHARACTER(LEN=*), INTENT(IN) :: tname, keyn
1411	TYPE(keys_type), INTENT(IN) :: ky(:)
1412	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def_val
1413	LOGICAL, OPTIONAL, INTENT(OUT) :: lerr
1414	!------------------------------------------------------------------------------------------------------------------------------
1415	val = fgetKeyIdx_s1(strIdx(ky(:)%name, tname), keyn, ky, def_val, lerr)
1416	END FUNCTION fgetKeyNam_s1
1417	!==============================================================================================================================
1418	FUNCTION fgetKeys(keyn, ky, def_val, lerr) RESULT(val)
1419	CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:)
1420	CHARACTER(LEN=*), INTENT(IN) :: keyn
1421	TYPE(keys_type), INTENT(IN) :: ky(:)
1422	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def_val
1423	LOGICAL, OPTIONAL, INTENT(OUT) :: lerr
1424	!------------------------------------------------------------------------------------------------------------------------------
1425	LOGICAL :: ler(SIZE(ky))
1426	INTEGER :: it
1427	val = [(fgetKeyIdx_s1(it, keyn, ky, def_val, ler(it)), it = 1, SIZE(ky))]
1428	IF(PRESENT(lerr)) lerr = ANY(ler)
1429	END FUNCTION fgetKeys
1430	!==============================================================================================================================
1431
1432
1433	!==============================================================================================================================
1434	!========== GET THE VALUE OF A KEY FROM A "keys_type" DERIVED TYPE ; THE RETURNED VALUE IS THE ERROR CODE ==============
1435	!========== The key "keyn" is searched in: 1) "ky(:)%name" (if given) ==============
1436	!========== 2) "tracers(:)%name" ==============
1437	!========== 3) "isotope%keys(:)%name" ==============
1438	!========== for the tracer[s] "tname[(:)]" (if given) or all the available tracers from the used set otherwise. ==============
1439	!========== The type of the returned value(s) can be string, integer or real, scalar or vector ==============
1440	!==============================================================================================================================
1441	LOGICAL FUNCTION getKeyByName_s1(keyn, val, tname, ky) RESULT(lerr)
1442	CHARACTER(LEN=*), INTENT(IN) :: keyn
1443	CHARACTER(LEN=maxlen), INTENT(OUT) :: val
1444	CHARACTER(LEN=*), INTENT(IN) :: tname
1445	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1446	!------------------------------------------------------------------------------------------------------------------------------
1447	CHARACTER(LEN=maxlen) :: tnam
1448	tnam = strHead(delPhase(tname),'_',.FALSE.) !--- Remove tag and phase
1449	IF(PRESENT(ky)) THEN !=== KEY FROM "ky"
1450	val = fgetKeyNam_s1(tname, keyn, ky, lerr=lerr) !--- "ky" and "tname"
1451	IF( lerr ) val = fgetKeyNam_s1(tnam, keyn, ky, lerr=lerr) !--- "ky" and "tnam"
1452	ELSE
1453	IF( .NOT.test(.NOT.ALLOCATED(tracers ), lerr)) lerr = SIZE(tracers ) == 0 !=== KEY FROM "tracers"
1454	IF(.NOT.lerr) THEN
1455	val = fgetKeyNam_s1(tname, keyn, tracers%keys, lerr=lerr) !--- "ky" and "tname"
1456	IF(lerr) val = fgetKeyNam_s1(tnam, keyn, tracers%keys, lerr=lerr) !--- "ky" and "tnam"
1457	END IF
1458	IF(lerr.AND..NOT.test(.NOT.ALLOCATED(isotopes), lerr)) lerr = SIZE(isotopes) == 0 !=== KEY FROM "isotope"
1459	IF(.NOT.lerr) THEN
1460	val = fgetKeyNam_s1(tname, keyn, isotope%keys, lerr=lerr) !--- "ky" and "tname"
1461	IF(lerr) val = fgetKeyNam_s1(tnam, keyn, isotope%keys, lerr=lerr) !--- "ky" and "tnam"
1462	END IF
1463	END IF
1464	END FUNCTION getKeyByName_s1
1465	!==============================================================================================================================
1466	LOGICAL FUNCTION getKeyByName_s1m(keyn, val, tname, ky) RESULT(lerr)
1467	CHARACTER(LEN=*), INTENT(IN) :: keyn
1468	CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
1469	CHARACTER(LEN=*), INTENT(IN) :: tname
1470	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1471	!------------------------------------------------------------------------------------------------------------------------------
1472	CHARACTER(LEN=maxlen) :: sval
1473	lerr = getKeyByName_s1(keyn, sval, tname, ky)
1474	IF(test(fmsg('missing key "'//TRIM(keyn)//'" for tracer "'//TRIM(tname)//'"', modname, lerr), lerr)) RETURN
1475	lerr = strParse(sval, ',', val)
1476	END FUNCTION getKeyByName_s1m
1477	!==============================================================================================================================
1478	LOGICAL FUNCTION getKeyByName_sm(keyn, val, tname, ky, nam) RESULT(lerr)
1479	CHARACTER(LEN=*), INTENT(IN) :: keyn
1480	CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
1481	CHARACTER(LEN=*), INTENT(IN) :: tname(:)
1482	TYPE(keys_type), OPTIONAL, TARGET, INTENT(IN) :: ky(:)
1483	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1484	!------------------------------------------------------------------------------------------------------------------------------
1485	TYPE(keys_type), POINTER :: keys(:)
1486	LOGICAL :: lk, lt, li, ll
1487	INTEGER :: iq, nq
1488
1489	!--- DETERMINE THE DATABASE TO BE USED (ky, tracers or isotope)
1490	lk = PRESENT(ky)
1491	lt = .NOT.lk .AND. ALLOCATED(tracers); IF(lt) lt = SIZE(tracers) /= 0; IF(lt) lt = ANY(tracers(1)%keys%key(:) == keyn)
1492	li = .NOT.lt .AND. ALLOCATED(isotopes); IF(li) li = SIZE(isotopes) /= 0; IF(li) li = ANY(isotope%keys(1)%key(:) == keyn)
1493
1494	!--- LINK "keys" TO THE RIGHT DATABASE
1495	IF(test(.NOT.ANY([lk,lt,li]), lerr)) RETURN
1496	IF(lk) keys => ky(:)
1497	IF(lt) keys => tracers(:)%keys
1498	IF(li) keys => isotope%keys(:)
1499
1500	!--- GET THE DATA
1501	nq = SIZE(tname)
1502	ALLOCATE(val(nq))
1503	lerr = ANY([(getKeyByName_s1(keyn, val(iq), tname(iq), keys(:)), iq=1, nq)])
1504	IF(PRESENT(nam)) nam = tname(:)
1505
1506	END FUNCTION getKeyByName_sm
1507	!==============================================================================================================================
1508	LOGICAL FUNCTION getKey_sm(keyn, val, ky, nam) RESULT(lerr)
1509	CHARACTER(LEN=*), INTENT(IN) :: keyn
1510	CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
1511	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1512	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1513	!------------------------------------------------------------------------------------------------------------------------------
1514	! Note: if names are repeated, getKeyByName_sm can't be used ; this routine, using indexes, must be used instead.
1515	IF(PRESENT(ky)) THEN !=== KEY FROM "ky"
1516	val = fgetKeys(keyn, ky, lerr=lerr)
1517	IF(PRESENT(nam)) nam = ky(:)%name
1518	ELSE
1519	IF( .NOT.test(.NOT.ALLOCATED(tracers ), lerr)) lerr = SIZE(tracers ) == 0 !=== KEY FROM "tracers"
1520	IF(.NOT.lerr) val = fgetKeys(keyn, tracers%keys, lerr=lerr)
1521	IF(.NOT.lerr.AND.PRESENT(nam)) nam = tracers(:)%keys%name
1522	IF(lerr.AND..NOT.test(.NOT.ALLOCATED(isotopes), lerr)) lerr = SIZE(isotopes) == 0 !=== KEY FROM "isotope"
1523	IF(.NOT.lerr) val = fgetKeys(keyn, isotope%keys, lerr=lerr)
1524	IF(.NOT.lerr.AND.PRESENT(nam)) nam = isotope%keys(:)%name
1525	END IF
1526	END FUNCTION getKey_sm
1527	!==============================================================================================================================
1528	LOGICAL FUNCTION getKeyByName_i1(keyn, val, tname, ky) RESULT(lerr)
1529	CHARACTER(LEN=*), INTENT(IN) :: keyn
1530	INTEGER, INTENT(OUT) :: val
1531	CHARACTER(LEN=*), INTENT(IN) :: tname
1532	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1533	!------------------------------------------------------------------------------------------------------------------------------
1534	CHARACTER(LEN=maxlen) :: sval
1535	INTEGER :: ierr
1536	lerr = getKeyByName_s1(keyn, sval, tname, ky)
1537	IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tname)//'" is missing', modname, lerr), lerr)) RETURN
1538	READ(sval, *, IOSTAT=ierr) val
1539	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not an integer', modname, ierr/=0), lerr)) RETURN
1540	END FUNCTION getKeyByName_i1
1541	!==============================================================================================================================
1542	LOGICAL FUNCTION getKeyByName_i1m(keyn, val, tname, ky) RESULT(lerr)
1543	CHARACTER(LEN=*), INTENT(IN) :: keyn
1544	INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:)
1545	CHARACTER(LEN=*), INTENT(IN) :: tname
1546	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1547	!------------------------------------------------------------------------------------------------------------------------------
1548	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:)
1549	INTEGER :: ierr, iq, nq
1550	IF(test(getKeyByName_s1m(keyn, sval, tname, ky), lerr)) RETURN
1551	nq = SIZE(sval); ALLOCATE(val(nq))
1552	lerr = .FALSE.; DO iq=1, nq; READ(sval(iq), *, IOSTAT=ierr) val(iq); lerr = lerr .OR. ierr /= 0; END DO
1553	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not an integer', modname, lerr), lerr)) RETURN
1554	END FUNCTION getKeyByName_i1m
1555	!==============================================================================================================================
1556	LOGICAL FUNCTION getKeyByName_im(keyn, val, tname, ky, nam) RESULT(lerr)
1557	CHARACTER(LEN=*), INTENT(IN) :: keyn
1558	INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:)
1559	CHARACTER(LEN=*), INTENT(IN) :: tname(:)
1560	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1561	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1562	!------------------------------------------------------------------------------------------------------------------------------
1563	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:)
1564	INTEGER :: ierr, iq, nq
1565	IF(test(getKeyByName_sm(keyn, sval, tname, ky, names), lerr)) RETURN
1566	nq = SIZE(sval); ALLOCATE(val(nq))
1567	DO iq = 1, nq !--- CONVERT THE KEYS TO INTEGERS
1568	READ(sval(iq), *, IOSTAT=ierr) val(iq)
1569	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not an integer', modname, ierr/=0), lerr)) RETURN
1570	END DO
1571	END FUNCTION getKeyByName_im
1572	!==============================================================================================================================
1573	LOGICAL FUNCTION getKey_im(keyn, val, ky, nam) RESULT(lerr)
1574	CHARACTER(LEN=*), INTENT(IN) :: keyn
1575	INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:)
1576	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1577	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1578	!------------------------------------------------------------------------------------------------------------------------------
1579	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:)
1580	INTEGER :: ierr, iq, nq
1581	IF(test(getKey_sm(keyn, sval, ky, names), lerr)) RETURN
1582	nq = SIZE(sval); ALLOCATE(val(nq))
1583	DO iq = 1, nq
1584	READ(sval(iq), *, IOSTAT=ierr) val(iq)
1585	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not an integer', modname, ierr/=0), lerr)) RETURN
1586	END DO
1587	IF(PRESENT(nam)) nam = names
1588	END FUNCTION getKey_im
1589	!==============================================================================================================================
1590	LOGICAL FUNCTION getKeyByName_r1(keyn, val, tname, ky) RESULT(lerr)
1591	CHARACTER(LEN=*), INTENT(IN) :: keyn
1592	REAL, INTENT(OUT) :: val
1593	CHARACTER(LEN=*), INTENT(IN) :: tname
1594	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1595	!------------------------------------------------------------------------------------------------------------------------------
1596	CHARACTER(LEN=maxlen) :: sval
1597	INTEGER :: ierr
1598	lerr = getKeyByName_s1(keyn, sval, tname, ky)
1599	IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tname)//'" is missing', modname, lerr), lerr)) RETURN
1600	READ(sval, *, IOSTAT=ierr) val
1601	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not a real', modname, ierr/=0), lerr)) RETURN
1602	END FUNCTION getKeyByName_r1
1603	!==============================================================================================================================
1604	LOGICAL FUNCTION getKeyByName_r1m(keyn, val, tname, ky) RESULT(lerr)
1605	CHARACTER(LEN=*), INTENT(IN) :: keyn
1606	REAL, ALLOCATABLE, INTENT(OUT) :: val(:)
1607	CHARACTER(LEN=*), INTENT(IN) :: tname
1608	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1609	!------------------------------------------------------------------------------------------------------------------------------
1610	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:)
1611	INTEGER :: ierr, iq, nq
1612	IF(test(getKeyByName_s1m(keyn, sval, tname, ky), lerr)) RETURN
1613	nq = SIZE(sval); ALLOCATE(val(nq))
1614	lerr = .FALSE.; DO iq=1, nq; READ(sval(iq), *, IOSTAT=ierr) val(iq); lerr = lerr .OR. ierr /= 0; END DO
1615	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not a vector of reals', modname, lerr), lerr)) RETURN
1616	END FUNCTION getKeyByName_r1m
1617	!==============================================================================================================================
1618	LOGICAL FUNCTION getKeyByName_rm(keyn, val, tname, ky, nam) RESULT(lerr)
1619	CHARACTER(LEN=*), INTENT(IN) :: keyn
1620	REAL, ALLOCATABLE, INTENT(OUT) :: val(:)
1621	CHARACTER(LEN=*), INTENT(IN) :: tname(:)
1622	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1623	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1624	!------------------------------------------------------------------------------------------------------------------------------
1625	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:)
1626	INTEGER :: ierr, iq, nq
1627	IF(test(getKeyByName_sm(keyn, sval, tname, ky, names), lerr)) RETURN
1628	nq = SIZE(sval); ALLOCATE(val(nq))
1629	DO iq = 1, nq !--- CONVERT THE KEYS TO INTEGERS
1630	READ(sval(iq), *, IOSTAT=ierr) val(iq)
1631	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not a real', modname, ierr/=0), lerr)) RETURN
1632	END DO
1633	IF(PRESENT(nam)) nam = names
1634	END FUNCTION getKeyByName_rm
1635	!==============================================================================================================================
1636	LOGICAL FUNCTION getKey_rm(keyn, val, ky, nam) RESULT(lerr)
1637	CHARACTER(LEN=*), INTENT(IN) :: keyn
1638	REAL, ALLOCATABLE, INTENT(OUT) :: val(:)
1639	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1640	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1641	!------------------------------------------------------------------------------------------------------------------------------
1642	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:)
1643	INTEGER :: ierr, iq, nq
1644	IF(test(getKey_sm(keyn, sval, ky, names), lerr)) RETURN
1645	nq = SIZE(sval); ALLOCATE(val(nq))
1646	DO iq = 1, nq !--- CONVERT THE KEYS TO INTEGERS
1647	READ(sval(iq), *, IOSTAT=ierr) val(iq)
1648	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not a real', modname, ierr/=0), lerr)) RETURN
1649	END DO
1650	IF(PRESENT(nam)) nam = names
1651	END FUNCTION getKey_rm
1652	!==============================================================================================================================
1653	LOGICAL FUNCTION getKeyByName_l1(keyn, val, tname, ky) RESULT(lerr)
1654	USE strings_mod, ONLY: str2bool
1655	CHARACTER(LEN=*), INTENT(IN) :: keyn
1656	LOGICAL, INTENT(OUT) :: val
1657	CHARACTER(LEN=*), INTENT(IN) :: tname
1658	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1659	!------------------------------------------------------------------------------------------------------------------------------
1660	CHARACTER(LEN=maxlen) :: sval
1661	INTEGER :: ierr
1662	lerr = getKeyByName_s1(keyn, sval, tname, ky)
1663	IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tname)//'" is missing', modname, lerr), lerr)) RETURN
1664	val = str2bool(sval)
1665	END FUNCTION getKeyByName_l1
1666	!==============================================================================================================================
1667	LOGICAL FUNCTION getKeyByName_l1m(keyn, val, tname, ky) RESULT(lerr)
1668	USE strings_mod, ONLY: str2bool
1669	CHARACTER(LEN=*), INTENT(IN) :: keyn
1670	LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:)
1671	CHARACTER(LEN=*), INTENT(IN) :: tname
1672	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1673	!------------------------------------------------------------------------------------------------------------------------------
1674	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:)
1675	INTEGER :: ierr, iq, nq
1676	IF(test(getKeyByName_s1m(keyn, sval, tname, ky), lerr)) RETURN
1677	nq = SIZE(sval); ALLOCATE(val(nq))
1678	lerr = .FALSE.; DO iq=1, nq; val(iq)=str2bool(sval(iq)); END DO
1679	END FUNCTION getKeyByName_l1m
1680	!==============================================================================================================================
1681	LOGICAL FUNCTION getKeyByName_lm(keyn, val, tname, ky, nam) RESULT(lerr)
1682	USE strings_mod, ONLY: str2bool
1683	CHARACTER(LEN=*), INTENT(IN) :: keyn
1684	LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:)
1685	CHARACTER(LEN=*), INTENT(IN) :: tname(:)
1686	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1687	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1688	!------------------------------------------------------------------------------------------------------------------------------
1689	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:)
1690	INTEGER :: ierr, iq, nq
1691	IF(test(getKeyByName_sm(keyn, sval, tname, ky, nam), lerr)) RETURN
1692	nq = SIZE(sval); ALLOCATE(val(nq))
1693	lerr = .FALSE.; DO iq=1, nq; val(iq)=str2bool(sval(iq)); END DO
1694	END FUNCTION getKeyByName_lm
1695	!==============================================================================================================================
1696	LOGICAL FUNCTION getKey_lm(keyn, val, ky, nam) RESULT(lerr)
1697	USE strings_mod, ONLY: str2bool
1698	CHARACTER(LEN=*), INTENT(IN) :: keyn
1699	LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:)
1700	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1701	CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1702	!------------------------------------------------------------------------------------------------------------------------------
1703	CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:)
1704	INTEGER :: ierr, iq, nq
1705	IF(test(getKey_sm(keyn, sval, ky, nam), lerr)) RETURN
1706	nq = SIZE(sval); ALLOCATE(val(nq))
1707	lerr = .FALSE.; DO iq=1, nq; val(iq)=str2bool(sval(iq)); END DO
1708	END FUNCTION getKey_lm
1709	!==============================================================================================================================
1710
1711
1712	!==============================================================================================================================
1713	!=== ROUTINES TO GET OR PUT TRACERS AND ISOTOPES DATABASES, SINCE tracers AND isotopes ARE PRIVATE VARIABLES ==================
1714	!==============================================================================================================================
1715	SUBROUTINE setKeysDBase(tracers_, isotopes_, isotope_)
1716	TYPE(trac_type), OPTIONAL, INTENT(IN) :: tracers_(:)
1717	TYPE(isot_type), OPTIONAL, INTENT(IN) :: isotopes_(:)
1718	TYPE(isot_type), OPTIONAL, INTENT(IN) :: isotope_
1719	!------------------------------------------------------------------------------------------------------------------------------
1720	TYPE(isot_type), ALLOCATABLE :: iso(:)
1721	INTEGER :: ix, nbIso
1722	IF(PRESENT( tracers_)) THEN; tracers = tracers_; ELSE; ALLOCATE( tracers(0)); END IF
1723	IF(PRESENT(isotopes_)) THEN; isotopes = isotopes_; ELSE; ALLOCATE(isotopes(0)); END IF
1724	IF(PRESENT(isotope_ )) THEN
1725	ix = strIdx(isotopes(:)%parent, isotope_%parent)
1726	IF(ix /= 0) THEN
1727	isotopes(ix) = isotope_
1728	ELSE
1729	nbIso = SIZE(isotopes); ALLOCATE(iso(nbIso+1)); iso(1:nbIso) = isotopes; iso(nbIso+1) = isotope_
1730	CALL MOVE_ALLOC(FROM=iso, TO=isotopes)
1731	END IF
1732	END IF
1733	END SUBROUTINE setKeysDBase
1734	!==============================================================================================================================
1735	SUBROUTINE getKeysDBase(tracers_, isotopes_, isotope_)
1736	TYPE(trac_type), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: tracers_(:)
1737	TYPE(isot_type), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: isotopes_(:)
1738	TYPE(isot_type), OPTIONAL, INTENT(OUT) :: isotope_
1739	!------------------------------------------------------------------------------------------------------------------------------
1740	INTEGER :: ix
1741	IF(PRESENT( tracers_)) THEN; tracers_ = tracers; ELSE; ALLOCATE( tracers_(0)); END IF
1742	IF(PRESENT(isotopes_)) THEN; isotopes_ = isotopes; ELSE; ALLOCATE(isotopes_(0)); END IF
1743	IF(PRESENT(isotope_ )) THEN; ix = strIdx(isotopes(:)%parent, isotope%parent); IF(ix /= 0) isotope_=isotopes(ix); END IF
1744	END SUBROUTINE getKeysDBase
1745	!==============================================================================================================================
1746
1747
1748	!==============================================================================================================================
1749	!=== REMOVE, IF ANY, OR ADD THE PHASE SUFFIX OF THE TRACER NAMED "s" ==========================================================
1750	!==============================================================================================================================
1751	ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION delPhase(s) RESULT(out)
1752	CHARACTER(LEN=*), INTENT(IN) :: s
1753	!------------------------------------------------------------------------------------------------------------------------------
1754	INTEGER :: ix, ip, ns
1755	out = s; ns = LEN_TRIM(s)
1756	IF(s == '') RETURN !--- Empty string: nothing to do
1757	IF(s(1:3)=='H2O' .AND. INDEX(old_phases,s(4:4))/=0 .AND. (ns==4 .OR. s(5:5)=='_')) THEN
1758	out='H2O'//s(5:ns) !--- H2O<phase>[_<iso>][_<tag>]
1759	ELSE IF(s(ns-1:ns-1)==phases_sep .AND. INDEX(known_phases,s(ns:ns))/=0) THEN
1760	out = s(1:ns-2); RETURN !--- <var><phase_sep><phase>
1761	ELSE; DO ip = 1, nphases; ix = INDEX(s, phases_sep//known_phases(ip:ip)//'_'); IF(ix /= 0) EXIT; END DO
1762	IF(ip /= nphases+1) out = s(1:ix-1)//s(ix+2:ns) !--- <var><phase_sep><phase>_<tag>
1763	END IF
1764	END FUNCTION delPhase
1765	!==============================================================================================================================
1766	CHARACTER(LEN=maxlen) FUNCTION addPhase_s1(s,pha) RESULT(out)
1767	CHARACTER(LEN=*), INTENT(IN) :: s
1768	CHARACTER(LEN=1), INTENT(IN) :: pha
1769	!------------------------------------------------------------------------------------------------------------------------------
1770	INTEGER :: l, i
1771	out = s
1772	IF(s == '') RETURN !--- Empty string: nothing to do
1773	i = INDEX(s, '_') !--- /=0 for <var>_<tag> tracers names
1774	l = LEN_TRIM(s)
1775	IF(i == 0) out = TRIM(s)//phases_sep//pha !--- <var> => return <var><sep><pha>
1776	IF(i /= 0) out = s(1:i-1)//phases_sep//pha//'_'//s(i+1:l) !--- <var>_<tag> => return <var><sep><pha>_<tag>
1777	END FUNCTION addPhase_s1
1778	!==============================================================================================================================
1779	FUNCTION addPhase_sm(s,pha) RESULT(out)
1780	CHARACTER(LEN=*), INTENT(IN) :: s(:)
1781	CHARACTER(LEN=1), INTENT(IN) :: pha
1782	CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:)
1783	!------------------------------------------------------------------------------------------------------------------------------
1784	INTEGER :: k
1785	out = [( addPhase_s1(s(k), pha), k=1, SIZE(s) )]
1786	END FUNCTION addPhase_sm
1787	!==============================================================================================================================
1788	CHARACTER(LEN=maxlen) FUNCTION addPhase_i1(s,ipha,phases) RESULT(out)
1789	CHARACTER(LEN=*), INTENT(IN) :: s
1790	INTEGER, INTENT(IN) :: ipha
1791	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases
1792	!------------------------------------------------------------------------------------------------------------------------------
1793	out = s
1794	IF(s == '') RETURN !--- Empty string: nothing to do
1795	IF(ipha == 0 .OR. ipha > nphases) RETURN !--- Absurd index: no phase to add
1796	IF( PRESENT(phases)) out = addPhase_s1(s, phases(ipha:ipha))
1797	IF(.NOT.PRESENT(phases)) out = addPhase_s1(s, known_phases(ipha:ipha))
1798	END FUNCTION addPhase_i1
1799	!==============================================================================================================================
1800	FUNCTION addPhase_im(s,ipha,phases) RESULT(out)
1801	CHARACTER(LEN=*), INTENT(IN) :: s(:)
1802	INTEGER, INTENT(IN) :: ipha
1803	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases
1804	CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:)
1805	!------------------------------------------------------------------------------------------------------------------------------
1806	INTEGER :: k
1807	IF( PRESENT(phases)) out = [( addPhase_i1(s(k), ipha, phases), k=1, SIZE(s) )]
1808	IF(.NOT.PRESENT(phases)) out = [( addPhase_i1(s(k), ipha, known_phases), k=1, SIZE(s) )]
1809	END FUNCTION addPhase_im
1810	!==============================================================================================================================
1811
1812
1813	!==============================================================================================================================
1814	!=== GET PHASE INDEX IN THE POSSIBLE PHASES LIST OR IN A SPECIFIED LIST ("phases") ============================================
1815	!==============================================================================================================================
1816	INTEGER FUNCTION getiPhase(tname, phases) RESULT(iPhase)
1817	CHARACTER(LEN=*), INTENT(IN) :: tname
1818	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases
1819	!------------------------------------------------------------------------------------------------------------------------------
1820	CHARACTER(LEN=maxlen) :: phase
1821	IF( PRESENT(phases)) phase = getPhase(tname, phases, iPhase)
1822	IF(.NOT.PRESENT(phases)) phase = getPhase(tname, known_phases, iPhase)
1823	END FUNCTION getiPhase
1824	!==============================================================================================================================
1825	CHARACTER(LEN=1) FUNCTION getPhase(tname, phases, iPhase) RESULT(phase)
1826	CHARACTER(LEN=*), INTENT(IN) :: tname
1827	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases
1828	INTEGER, OPTIONAL, INTENT(OUT) :: iPhase
1829	!------------------------------------------------------------------------------------------------------------------------------
1830	INTEGER :: ip
1831	phase = TRIM(strHead(strTail(tname, phases_sep, .TRUE.), '_', .TRUE.))
1832	IF( PRESENT(phases)) ip = INDEX( phases, phase)
1833	IF(.NOT.PRESENT(phases)) ip = INDEX(known_phases, phase)
1834	IF(ip == 0) phase = 'g'
1835	IF(PRESENT(iPhase)) iPhase = ip
1836	END FUNCTION getPhase
1837	!==============================================================================================================================
1838
1839
1840	!==============================================================================================================================
1841	!============ CONVERT WATER-DERIVED NAMES FROM FORMER TO CURRENT CONVENTION ; OTHER NAMES ARE LEFT UNTOUCHED ==================
1842	!======= NAMES STRUCTURE: H2O[<phase>][_<isotope>][_<tag>] (<phase> from "old_phases", <isotope> from "oldH2OIso") ============
1843	!==============================================================================================================================
1844	CHARACTER(LEN=maxlen) FUNCTION old2newH2O_1(oldName, iPhase) RESULT(newName)
1845	CHARACTER(LEN=*), INTENT(IN) :: oldName
1846	INTEGER, OPTIONAL, INTENT(OUT) :: iPhase
1847	!------------------------------------------------------------------------------------------------------------------------------
1848	CHARACTER(LEN=maxlen), ALLOCATABLE :: tmp(:)
1849	INTEGER :: ix, ip, nt
1850	LOGICAL :: lerr
1851	newName = oldName
1852	IF(PRESENT(iPhase)) iPhase = 1 !--- Default: gaseous phase
1853	lerr = strParse(oldName, '_', tmp, n=nt) !--- Parsing: 1 up to 3 elements.
1854	ip = strIdx( [('H2O'//old_phases(ix:ix), ix=1, nphases)], tmp(1) ) !--- Phase index
1855	IF(ip /= 0 .AND. PRESENT(iPhase)) iPhase = ip !--- Returning phase index
1856	IF(ip == 0 .AND. tmp(1) /= 'H2O') RETURN !--- Not an old-style water-related species
1857	IF(nt == 1) THEN
1858	newName = addPhase('H2O',ip) !=== WATER WITH OR WITHOUT PHASE
1859	ELSE
1860	ix = strIdx(oldH2OIso, tmp(2)) !--- Index in the known isotopes list
1861	IF(ix /= 0) tmp(2) = newH2OIso(ix) !--- Move to new isotope name
1862	IF(ip /= 0) tmp(2) = addPhase(tmp(2), ip) !--- Add phase to isotope name
1863	newName = TRIM(strStack(tmp(2:nt), '_')) !=== WATER ISOTOPE OR TAGGING TRACER
1864	END IF
1865	END FUNCTION old2newH2O_1
1866	!==============================================================================================================================
1867	FUNCTION old2newH2O_m(oldName) RESULT(newName)
1868	CHARACTER(LEN=*), INTENT(IN) :: oldName(:)
1869	CHARACTER(LEN=maxlen) :: newName(SIZE(oldName))
1870	!------------------------------------------------------------------------------------------------------------------------------
1871	INTEGER :: i
1872	newName = [(old2newH2O_1(oldName(i)), i=1, SIZE(oldName))]
1873	END FUNCTION old2newH2O_m
1874	!==============================================================================================================================
1875
1876
1877	!==============================================================================================================================
1878	!============ CONVERT WATER-DERIVED NAMES FROM CURRENT TO FORMER CONVENTION ; OTHER NAMES ARE LEFT UNTOUCHED ==================
1879	!==== NAMES STRUCTURE: <var>[<phase_sep><phase>][_<tag>] (<phase> from "known_phases", <var> = 'H2O' or from "newH2OIso") =====
1880	!==============================================================================================================================
1881	CHARACTER(LEN=maxlen) FUNCTION new2oldH2O_1(newName, iPhase) RESULT(oldName)
1882	CHARACTER(LEN=*), INTENT(IN) :: newName
1883	INTEGER, OPTIONAL, INTENT(OUT) :: iPhase
1884	!------------------------------------------------------------------------------------------------------------------------------
1885	CHARACTER(LEN=maxlen), ALLOCATABLE :: tmp(:)
1886	INTEGER :: ix, ip
1887	CHARACTER(LEN=maxlen) :: var
1888	oldName = newName
1889	IF(PRESENT(iPhase)) iPhase = 1 !--- Default: gaseous phase
1890	ip = getiPhase(newName) !--- Phase index
1891	IF(ip /= 0 .AND. PRESENT(iPhase)) iPhase = ip !--- Returning phase index
1892	ix = strIdx(newH2OIso, newName) !--- Index in the known H2O isotopes list
1893	IF(ix /= 0) oldName = 'H2O'//'_'//TRIM(oldH2OIso(ix)) !=== WATER ISOTOPE WITHOUT PHASE
1894	IF(ix /= 0 .OR. ip == 0) RETURN
1895	oldName = 'H2O'//old_phases(ip:ip)
1896	IF(newName == addPhase('H2O', ip)) RETURN !=== WATER WITH PHASE
1897	var = TRIM(strHead(newName, phases_sep, .TRUE.)) !--- Head variable name (no phase)
1898	ix = strIdx(newH2OIso, var) !--- Index in the known H2O isotopes list
1899	IF(ix == 0) RETURN !=== H2O[vli]_<var> (<var> /= H2O isotope)
1900	oldName = TRIM(oldName)//'_'//TRIM(oldH2OIso(ix)) !=== WATER ISOTOPE WITH PHASE
1901	var = addPhase(var, ip) !--- Head variable with phase
1902	IF(newName /= var) oldName = TRIM(oldName)//strTail(newName, TRIM(var)) !=== WATER ISOTOPIC TAGGING TRACER
1903	END FUNCTION new2oldH2O_1
1904	!==============================================================================================================================
1905	FUNCTION new2oldH2O_m(newName) RESULT(oldName)
1906	CHARACTER(LEN=*), INTENT(IN) :: newName(:)
1907	CHARACTER(LEN=maxlen) :: oldName(SIZE(newName))
1908	!------------------------------------------------------------------------------------------------------------------------------
1909	INTEGER :: i
1910	oldName = [(new2oldH2O_1(newName(i)), i=1, SIZE(newName))]
1911	END FUNCTION new2oldH2O_m
1912	!==============================================================================================================================
1913
1914
1915	!==============================================================================================================================
1916	!=== GET THE NAME(S) OF THE ANCESTOR(S) OF TRACER(S) "tname" AT GENERATION "igen" IN THE TRACERS DESCRIPTORS LIST "tr" =======
1917	!==============================================================================================================================
1918	SUBROUTINE ancestor_1(t, out, tname, igen)
1919	TYPE(trac_type), INTENT(IN) :: t(:)
1920	CHARACTER(LEN=maxlen), INTENT(OUT) :: out
1921	CHARACTER(LEN=*), INTENT(IN) :: tname
1922	INTEGER, OPTIONAL, INTENT(IN) :: igen
1923	!------------------------------------------------------------------------------------------------------------------------------
1924	INTEGER :: ix
1925	CALL idxAncestor_1(t, ix, tname, igen)
1926	out = ''; IF(ix /= 0) out = t(ix)%name
1927	END SUBROUTINE ancestor_1
1928	!==============================================================================================================================
1929	SUBROUTINE ancestor_mt(t, out, tname, igen)
1930	TYPE(trac_type), INTENT(IN) :: t(:)
1931	CHARACTER(LEN=*), INTENT(IN) :: tname(:)
1932	CHARACTER(LEN=maxlen), INTENT(OUT) :: out(SIZE(tname))
1933	INTEGER, OPTIONAL, INTENT(IN) :: igen
1934	!------------------------------------------------------------------------------------------------------------------------------
1935	INTEGER :: ix(SIZE(tname))
1936	CALL idxAncestor_mt(t, ix, tname, igen)
1937	out(:) = ''; WHERE(ix /= 0) out = t(ix)%name
1938	END SUBROUTINE ancestor_mt
1939	!==============================================================================================================================
1940	SUBROUTINE ancestor_m(t, out, igen)
1941	TYPE(trac_type), INTENT(IN) :: t(:)
1942	CHARACTER(LEN=maxlen), INTENT(OUT) :: out(SIZE(t))
1943	INTEGER, OPTIONAL, INTENT(IN) :: igen
1944	!------------------------------------------------------------------------------------------------------------------------------
1945	INTEGER :: ix(SIZE(t))
1946	CALL idxAncestor_m(t, ix, igen)
1947	out(:) = ''; WHERE(ix /= 0) out = t(ix)%name
1948	END SUBROUTINE ancestor_m
1949	!==============================================================================================================================
1950
1951
1952	!==============================================================================================================================
1953	!=== GET THE INDEX(ES) OF THE GENERATION "igen" ANCESTOR(S) OF "tname" (t%name IF UNSPECIFIED) IN THE "t" LIST ================
1954	!==============================================================================================================================
1955	SUBROUTINE idxAncestor_1(t, idx, tname, igen)
1956	TYPE(trac_type), INTENT(IN) :: t(:)
1957	INTEGER, INTENT(OUT) :: idx
1958	CHARACTER(LEN=*), INTENT(IN) :: tname
1959	INTEGER, OPTIONAL, INTENT(IN) :: igen
1960	INTEGER :: ig
1961	ig = 0; IF(PRESENT(igen)) ig = igen
1962	idx = strIdx(t(:)%name, tname)
1963	IF(idx == 0) RETURN !--- Tracer not found
1964	IF(t(idx)%iGeneration <= ig) RETURN !--- Tracer has a lower generation number than asked generation 'igen"
1965	DO WHILE(t(idx)%iGeneration > ig); idx = strIdx(t(:)%name, t(idx)%parent); END DO
1966	END SUBROUTINE idxAncestor_1
1967	!------------------------------------------------------------------------------------------------------------------------------
1968	SUBROUTINE idxAncestor_mt(t, idx, tname, igen)
1969	TYPE(trac_type), INTENT(IN) :: t(:)
1970	CHARACTER(LEN=*), INTENT(IN) :: tname(:)
1971	INTEGER, INTENT(OUT) :: idx(SIZE(tname))
1972	INTEGER, OPTIONAL, INTENT(IN) :: igen
1973	INTEGER :: ix
1974	DO ix = 1, SIZE(tname); CALL idxAncestor_1(t, idx(ix), tname(ix), igen); END DO
1975	END SUBROUTINE idxAncestor_mt
1976	!------------------------------------------------------------------------------------------------------------------------------
1977	SUBROUTINE idxAncestor_m(t, idx, igen)
1978	TYPE(trac_type), INTENT(IN) :: t(:)
1979	INTEGER, INTENT(OUT) :: idx(SIZE(t))
1980	INTEGER, OPTIONAL, INTENT(IN) :: igen
1981	INTEGER :: ix
1982	DO ix = 1, SIZE(t); CALL idxAncestor_1(t, idx(ix), t(ix)%name, igen); END DO
1983	END SUBROUTINE idxAncestor_m
1984	!==============================================================================================================================
1985
1986
1987	END MODULE readTracFiles_mod

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

Download in other formats:

Original Format