Context Navigation

source: readTracFiles_mod.f90 @ 26

Last change on this file since 26 was 26, checked in by dcugnet, 22 months ago

Modification to solve a gfortran specific bug ; this compiler wrongly claims:

Error: Ambiguous interfaces in generic interface 'fgetkey' for ‘fgetkeynam_s1’ at (1) and ‘fgetkey_sm’ at (2)
But they are not:

FUNCTION fgetKeyNam_s1(tname, keyn, ky[, def_val, lerr]) RESULT(val) with val being a scalar string
FUNCTION fgetKeym ( keyn, ky[, def_val, lerr]) RESULT(val) with val being a vector string

So no way to have a single generic interface => gGetKey_sm is renamed fGetKeys.

File size: 123.0 KB

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

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

Download in other formats:

Original Format