Context Navigation

readTracFiles_mod.f90 @ 5453

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

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

Download in other formats:

Original Format