Context Navigation

readTracFiles_mod.f90 @ 4984

Last change on this file since 4984 was 4984, checked in by crisi, 12 days ago
plenty of files that I forgot to commit last time.
File size: 130.4 KB

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

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

Download in other formats:

Original Format