Context Navigation

readTracFiles_mod.f90 @ 4399

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

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

Download in other formats:

Original Format