Context Navigation

readTracFiles_mod.f90 @ 4500

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

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

Download in other formats:

Original Format