Context Navigation

readTracFiles_mod.f90 @ 4046

Last change on this file since 4046 was 4046, checked in by dcugnet, 2 years ago

First commit for new tracers.

parser routines readTracFiles, strings_mod and tracer_types added in misc using revision 4 of https://svn.lmd.jussieu.fr/tracers-parser
tested in sequential and parallel mode using ioipsl.
for now, only two fields of "tracers(:)" derived type vector are used: "name" and "longName".

File size: 86.6 KB

Line
1	MODULE readTracFiles_mod
2
3	USE strings_mod, ONLY: msg, testFile, strFind, strStack, strReduce, strHead, strCount, find, maxlen, fmsg, &
4	removeComment, cat, checkList, strIdx, strParse, strReplace, strTail, reduceExpr, test, get_in, dispTable
5	USE trac_types_mod, ONLY : trac_type, isot_type, keys_type
6
7	IMPLICIT NONE
8
9	PRIVATE
10
11	PUBLIC :: initIsotopes, maxlen, trac_type, isot_type
12	PUBLIC :: readTracersFiles, aliasTracer, tracersSubset, indexUpdate!--- TOOLS ASSOCIATED TO TRACERS DESCRIPTORS
13	PUBLIC :: readIsotopesFile !--- TOOLS ASSOCIATED TO ISOTOPES DESCRIPTORS
14	PUBLIC :: getKey_init, getKey, setDirectKeys !--- GET/SET KEYS FROM/TO tracers & isotopes
15
16	PUBLIC :: known_phases, old_phases, nphases, phases_names, & !--- VARIABLES RELATED TO THE PHASES
17	phases_sep, delPhase, addPhase !--- + ROUTINES TO ADD/REMOVE PHASE TO/FROM A NAME
18
19	PUBLIC :: tran0, idxAncestor, ancestor !--- GENERATION 0 TRACER + TOOLS FOR GENERATIONS
20
21	!------------------------------------------------------------------------------------------------------------------------------
22	TYPE :: dataBase_type !=== TYPE FOR TRACERS SECTION
23	CHARACTER(LEN=maxlen) :: name !--- Section name
24	TYPE(trac_type), ALLOCATABLE :: trac(:) !--- Tracers descriptors
25	END TYPE dataBase_type
26	!------------------------------------------------------------------------------------------------------------------------------
27	INTERFACE getKey
28	MODULE PROCEDURE getKeyByName_s1, getKeyByName_i1, getKeyByName_r1, getKeyByName_sm, getKeyByName_im, getKeyByName_rm
29	END INTERFACE getKey
30	!------------------------------------------------------------------------------------------------------------------------------
31	INTERFACE tracersSubset; MODULE PROCEDURE trSubset_Indx, trSubset_Name, trSubset_gen0Name; END INTERFACE tracersSubset
32	INTERFACE idxAncestor; MODULE PROCEDURE idxAncestor_1, idxAncestor_m; END INTERFACE idxAncestor
33	INTERFACE ancestor; MODULE PROCEDURE ancestor_1, ancestor_m; END INTERFACE ancestor
34	INTERFACE addPhase; MODULE PROCEDURE addPhase_1, addPhase_m; END INTERFACE addPhase
35	!------------------------------------------------------------------------------------------------------------------------------
36
37	!=== MAIN DATABASE: files sections descriptors
38	TYPE(dataBase_type), SAVE, ALLOCATABLE, TARGET :: dBase(:)
39
40	!--- SOME PARAMETERS THAT ARE NOT LIKELY TO CHANGE OFTEN
41	CHARACTER(LEN=maxlen), SAVE :: tran0 = 'air' !--- Default transporting fluid
42	CHARACTER(LEN=maxlen), PARAMETER :: old_phases = 'vli' !--- Old phases for water (no separator)
43	CHARACTER(LEN=maxlen), PARAMETER :: known_phases = 'gls' !--- Known phases initials
44	INTEGER, PARAMETER :: nphases=LEN_TRIM(known_phases) !--- Number of phases
45	CHARACTER(LEN=maxlen), SAVE :: phases_names(nphases) & !--- Known phases names
46	= ['gaseous', 'liquid ', 'solid ']
47	CHARACTER(LEN=1), SAVE :: phases_sep = '_' !--- Phase separator
48	LOGICAL, SAVE :: tracs_merge = .TRUE. !--- Merge/stack tracers lists
49	LOGICAL, SAVE :: lSortByGen = .TRUE. !--- Sort by growing generation
50
51	!=== LOCAL COPIES OF THE TRACERS AND ISOTOPES DESCRIPTORS, USED BY getKey (INITIALIZED IN getKey_init)
52	TYPE(trac_type), ALLOCATABLE, TARGET, SAVE :: tracers(:)
53	TYPE(isot_type), ALLOCATABLE, TARGET, SAVE :: isotopes(:)
54
55	CHARACTER(LEN=maxlen) :: modname
56
57	CONTAINS
58
59	!==============================================================================================================================
60	!==============================================================================================================================
61	!=== READ ONE OR SEVERAL TRACER FILES AND FILL A "tr" TRACERS DESCRIPTOR DERIVED TYPE.
62	!=== THE RETURN VALUE fType DEPENDS ON WHAT IS FOUND:
63	!=== 0: NO ADEQUATE FILE FOUND ; DEFAULT VALUES MUST BE USED
64	!=== 1: AN "OLD STYLE" TRACERS FILE "traceur.def":
65	!=== First line: <nb tracers> Other lines: <hadv> <vadv> <tracer name> [<parent name>]
66	!=== 2: A "NEW STYLE" TRACERS FILE "tracer.def" WITH SEVERAL SECTIONS.
67	!=== 3: SEVERAL " " TRACERS FILES "tracer_<component>.def" WITH A SINGLE SECTION IN EACH.
68	!=== REMARKS:
69	!=== * EACH SECTION BEGINS WITH A "&<section name> LINE
70	!=== * DEFAULT VALUES FOR ALL THE SECTIONS OF THE FILE ARE DEFINED IN THE SPECIAL SECTION "&default"
71	!=== * EACH SECTION LINE HAS THE STRUCTURE: <name(s)> <key1>=<value1> <key2>=<value2> ...
72	!=== * SO FAR, THE DEFINED KEYS ARE: parent, phases, hadv, vadv, type
73	!=== * <name> AND <parent> CAN BE LISTS OF COMA-SEPARATED TRACERS ; THE ROUTINE EXPAND THESE FACTORIZATIONS.
74	!=== FUNCTION RETURN VALUE "lerr" IS FALSE IN CASE SOMETHING WENT WRONG.
75	!=== ABOUT THE KEYS:
76	! * The "keys" component (of type keys_type) is in principle enough to store everything we could need.
77	! But some variables are stored as direct-access keys to make the code more readable and because they are used often.
78	! * Most of the direct-access keys are set in this module, but some are not (lnam, iadv and itr for example).
79	! * Some of the direct-access keys must be updated (using the routine "setDirectKeys") is a subset of "tracers(:)"
80	! is extracted: the indexes are no longer valid for a subset (examples: tracers(:)%iqParent or tracers(:)%ichld).
81	! * If you need to convert a %key/%val pair into a direct-access key, add the corresponding line in "setDirectKeys".
82	!==============================================================================================================================
83	LOGICAL FUNCTION readTracersFiles(type_trac, fType, tracs) RESULT(lerr)
84	!------------------------------------------------------------------------------------------------------------------------------
85	CHARACTER(LEN=*), INTENT(IN) :: type_trac !--- List of components used
86	INTEGER, INTENT(OUT) :: fType !--- Type of input file found
87	TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: tracs(:)
88	CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:), sections(:), trac_files(:)
89	CHARACTER(LEN=maxlen) :: str, fname, mesg
90	INTEGER :: is, nsec, ierr, it, ntrac, ns, ip
91	LOGICAL, ALLOCATABLE :: ll(:), lGen3(:)
92	!------------------------------------------------------------------------------------------------------------------------------
93	lerr = .FALSE.
94	modname = 'readTracersFiles'
95	IF(.NOT.ALLOCATED(dBase)) ALLOCATE(dBase(0))
96
97	!--- Required sections + corresponding files names (new style single section case)
98	IF(test(strParse(type_trac, ',', sections), lerr)) RETURN !--- Parse "type_trac" list
99
100	nsec = SIZE(sections, DIM=1)
101	ALLOCATE(trac_files(nsec)); DO is=1, nsec; trac_files(is) = 'tracer_'//TRIM(sections(is))//'.def'; END DO
102
103	!--- LOOK AT AVAILABLE FILES
104	ll = .NOT.testFile(trac_files)
105	fType = 0
106	IF(.NOT.testFile('traceur.def') .AND. nsec==1) fType = 1 !--- OLD STYLE FILE
107	IF(.NOT.testFile('tracer.def')) fType = 2 !--- NEW STYLE ; SINGLE FILE, SEVERAL SECTIONS
108	IF(ALL(ll)) fType = 3 !--- NEW STYLE ; SEVERAL FILES, SINGLE SECTION USED
109	IF(ANY(ll) .AND. fType/=3) THEN !--- MISSING FILES
110	IF(test(checkList(trac_files, .NOT.ll, 'Failed reading tracers description', 'files', 'missing'), lerr)) RETURN
111	END IF
112
113	!--- TELLS WHAT WAS IS ABOUT TO BE USED
114	IF (fmsg('No adequate tracers description file(s) found ; default values will be used', modname, fType==0)) RETURN
115	CALL msg('Trying to read old-style tracers description file "traceur.def"', modname, fType==1)
116	CALL msg('Trying to read the new style multi-sections tracers description file "tracer.def"', modname, fType==2)
117	CALL msg('Trying to read the new style single section tracers description files "tracer_*.def"', modname, fType==3)
118
119	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
120	IF(fType==1) THEN !=== OLD FORMAT "traceur.def"
121	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
122	!--- OPEN THE "traceur.def" FILE
123	OPEN(90, FILE="traceur.def", FORM='formatted', STATUS='old', IOSTAT=ierr)
124
125	!--- GET THE TRACERS NUMBER
126	READ(90,'(i3)',IOSTAT=ierr)ntrac !--- Number of lines/tracers
127	IF(test(fmsg('Invalid format for "'//TRIM(fname)//'"', modname, ierr /= 0), lerr)) RETURN
128
129	!--- READ THE REMAINING LINES: <hadv> <vadv> <tracer> [<transporting fluid>]
130	ALLOCATE(tracs(ntrac))
131	DO it=1,ntrac !=== READ RAW DATA: loop on the line/tracer number
132	READ(90,'(a)',IOSTAT=ierr) str
133	IF(test(fmsg('Invalid format for "' //TRIM(fname)//'"', modname, ierr>0), lerr)) RETURN
134	IF(test(fmsg('Not enough lines in "'//TRIM(fname)//'"', modname, ierr<0), lerr)) RETURN
135	ll = strParse(str, ' ', s, n=ns)
136	tracs(it)%keys%key = ['hadv', 'vadv']
137	tracs(it)%keys%val = s(1:2)
138	CALL msg('This file is for air tracers only', modname, ns == 3 .AND. it == 1)
139	CALL msg('This files specifies the transporting fluid', modname, ns == 4 .AND. it == 1)
140	tracs(it)%name = TRIM(s(3)) !--- Name of the tracer
141	tracs(it)%phase = known_phases(1:1) !--- Phase (default: "g" for gazeous)
142	DO ip = 1, nphases !--- Deal with old water names
143	IF(s(3) /= 'H2O'//old_phases(ip:ip)) CYCLE
144	tracs(it)%phase = known_phases(ip:ip); tracs(it)%name = 'H2O'//phases_sep//TRIM(tracs(it)%phase)
145	END DO
146	tracs(it)%parent = tran0 !--- Default transporting fluid: Air
147	IF(ns == 4) tracs(it)%parent = s(4) !--- Transporting fluid name
148	END DO
149	CLOSE(90)
150
151	lGen3 = tracs%iGeneration==3
152	CALL setGeneration(tracs) !--- Determine tracs(:)%iGeneration values
153	IF(test(checkTracers(tracs, fname,fname),lerr)) RETURN !--- Detect orphans and check phases
154	IF(test(checkUnique (tracs,lGen3,fname,fname),lerr)) RETURN !--- Detect repeated tracers
155	CALL sortTracers (tracs) !--- Sort the tracers
156	CALL setDirectKeys(tracs) !--- Set the directly accessible keys
157	tracs(:)%keys%name = tracs(:)%name !--- Copy tracers names in keys components
158	RETURN
159	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
160	END IF
161	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
162
163	!=== USING NEW FORMAT TRACERS DESCRIPTION FILES WITH POSSIBLY SEVERAL SECTIONS
164	CALL msg('The multiple required sections will be MERGED.', modname, nsec > 1 .AND. tracs_merge)
165	CALL msg('The multiple required sections will be CUMULATED.', modname, nsec > 1 .AND. .NOT.tracs_merge)
166
167	!=== FEED THE DATABASE WITH THE RAW CONTENT OF THE FILE
168	SELECT CASE(fType)
169	CASE(2); lerr = feedDBase(["tracer.def"],[type_trac]) !--- Single file, coma-separated sections list
170	CASE(3); lerr = feedDBase(trac_files, sections ) !--- Multiple files, one section name each file
171	END SELECT
172	IF(lerr) RETURN
173	IF( tracs_merge) lerr = mergeTracers(dBase, tracs) !--- MERGE THE COMPONENTS OF THE DATABASE
174	IF(.NOT.tracs_merge) lerr = cumulTracers(dBase, tracs) !--- CUMULATE THE COMPONENTS OF THE DATABASE
175	IF(lerr) RETURN
176	CALL setDirectKeys(tracs) !--- Set the directly accessible keys
177
178	END FUNCTION readTracersFiles
179	!==============================================================================================================================
180
181	!==============================================================================================================================
182	LOGICAL FUNCTION feedDBase(fnames, snames) RESULT(lerr)
183	! Purpose: Read the sections "snames(is)" (coma-separated list) from each "fnames(is)"
184	! file and create the corresponding tracers set descriptors in the database "dBase":
185	! * dBase(id)%name : section name
186	! * dBase(id)%trac(:)%name : tracers names
187	! * dBase(id)%trac(it)%keys%key(:): names of keys associated to tracer dBase(id)%trac(it)%name
188	! * dBase(id)%trac(it)%keys%val(:): values of keys associated to tracer dBase(id)%trac(it)%name
189	!------------------------------------------------------------------------------------------------------------------------------
190	CHARACTER(LEN=*), INTENT(IN) :: fnames(:) !--- Files names
191	CHARACTER(LEN=*), INTENT(IN) :: snames(:) !--- Coma-deparated list of sections (one list each file)
192	INTEGER, ALLOCATABLE :: ndb(:) !--- Nuber of sections for each file
193	INTEGER, ALLOCATABLE :: ixf(:) !--- File index for each section of the expanded list
194	LOGICAL, ALLOCATABLE :: lTg(:) !--- Tagging tracers mask
195	CHARACTER(LEN=maxlen) :: fnm, snm, modname
196	INTEGER :: idb, i
197	LOGICAL :: ll
198	!------------------------------------------------------------------------------------------------------------------------------
199	modname = 'feedDBase'
200	!=== READ THE REQUIRED SECTIONS
201	ll = strCount(snames, ',', ndb) !--- Number of sections for each file
202	ALLOCATE(ixf(SUM(ndb)))
203	DO i=1, SIZE(fnames)
204	IF(test(readSections(fnames(i), snames(i), 'default'), lerr)) RETURN
205	ixf(1+SUM(ndb(1:i-1)):SUM(ndb(1:i))) = i !--- File index for each section of the expanded list
206	END DO
207	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
208	DO idb=1,SIZE(dBase) !--- LOOP ON THE LOADED SECTIONS
209	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
210	fnm = fnames(ixf(idb)); snm = dBase(idb)%name
211	IF(test(expandSection(dBase(idb)%trac, snm, fnm),lerr)) RETURN !--- EXPAND NAMES AND PARENTS LISTS
212	CALL setGeneration (dBase(idb)%trac) !--- DETERMINE GENERATION NUMBER
213	IF(test(checkTracers (dBase(idb)%trac, snm, fnm),lerr)) RETURN !--- CHECK ORPHANS AND PHASES
214	lTg = dBase(idb)%trac(:)%type == 'tag' !--- Flag for tagging tracers
215	IF(test(checkUnique (dBase(idb)%trac,lTg,snm,fnm),lerr)) RETURN !--- CHECK TRACERS UNIQUENESS
216	CALL expandPhases (dBase(idb)%trac) !--- EXPAND THE PHASES
217	CALL sortTracers (dBase(idb)%trac) !--- SORT TRACERS
218	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
219	END DO
220	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
221
222	!=== DISPLAY BASIC INFORMATION
223	lerr = ANY([( dispTraSection('Expanded list for section "'//TRIM(dBase(idb)%name)//'"', dBase(idb)%name, modname), &
224	idb=1, SIZE(dBase) )])
225	END FUNCTION feedDBase
226	!------------------------------------------------------------------------------------------------------------------------------
227
228	!------------------------------------------------------------------------------------------------------------------------------
229	LOGICAL FUNCTION readSections(fnam,snam,defName) RESULT(lerr)
230	!------------------------------------------------------------------------------------------------------------------------------
231	CHARACTER(LEN=*), INTENT(IN) :: fnam !--- File name
232	CHARACTER(LEN=*), INTENT(IN) :: snam !--- Coma-separated sections list
233	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: defName !--- Special section (default values) name
234	!------------------------------------------------------------------------------------------------------------------------------
235	TYPE(dataBase_type), ALLOCATABLE :: tdb(:)
236	CHARACTER(LEN=maxlen), ALLOCATABLE :: sec(:)
237	INTEGER, ALLOCATABLE :: ix(:)
238	INTEGER :: n0, idb, ndb, i, j
239	LOGICAL :: ll
240	!------------------------------------------------------------------------------------------------------------------------------
241	n0 = SIZE(dBase) + 1 !--- Index for next entry in the database
242	CALL readSections_all() !--- Read all the sections of file "fnam"
243	ndb= SIZE(dBase) !--- Current number of sections in the database
244	IF(PRESENT(defName)) THEN !--- Add default values to all the tracers
245	DO idb=n0,ndb; CALL addDefault(dBase(idb)%trac, defName); END DO !--- and remove the virtual tracer "defName"
246	END IF
247	ll = strParse(snam, ',', keys = sec) !--- Requested sections names
248	ix = strIdx(dBase(:)%name, sec(:)) !--- Indexes of requested sections in database
249	IF(test(checkList(sec, ix == 0, 'In file "'//TRIM(fnam)//'"','section(s)', 'missing'), lerr)) RETURN
250	tdb = dBase(:); dBase = [tdb(1:n0-1),tdb(PACK(ix, MASK=ix/=0))] !--- Keep requested sections only
251
252	CONTAINS
253
254	!------------------------------------------------------------------------------------------------------------------------------
255	SUBROUTINE readSections_all()
256	!------------------------------------------------------------------------------------------------------------------------------
257	CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:), v(:)
258	TYPE(trac_type), ALLOCATABLE :: tt(:)
259	TYPE(trac_type) :: tmp
260	CHARACTER(LEN=1024) :: str
261	CHARACTER(LEN=maxlen) :: secn
262	INTEGER :: ierr, n
263	!------------------------------------------------------------------------------------------------------------------------------
264	IF(.NOT.ALLOCATED(dBase)) ALLOCATE(dBase(0))
265	OPEN(90, FILE=fnam, FORM='formatted', STATUS='old')
266	DO; READ(90,'(a)', IOSTAT=ierr)str
267	IF(ierr /= 0 ) EXIT !--- Finished: error or end of file
268	IF(str(1:1)=='#') CYCLE !--- Skip comments lines
269	CALL removeComment(str) !--- Skip comments at the end of a line
270	IF(str == '') CYCLE !--- Skip empty line (probably at the end of the file)
271	IF(str(1:1)=='&') THEN !=== SECTION HEADER LINE
272	ndb = SIZE(dBase) !--- Number of sections so far
273	secn = str(2:LEN_TRIM(str))//' ' !--- Current section name
274	IF(ANY(dBase(:)%name == secn)) CYCLE !--- Already known section
275	IF(secn(1:7) == 'version') CYCLE !--- Skip the "version" special section
276	ndb = ndb + 1 !--- Extend database
277	ALLOCATE(tdb(ndb))
278	tdb(1:ndb-1) = dBase
279	tdb(ndb)%name = secn
280	ALLOCATE(tdb(ndb)%trac(0))
281	CALL MOVE_ALLOC(FROM=tdb, TO=dBase)
282	ELSE !=== TRACER LINE
283	ll = strParse(str,' ', keys = s, vals = v, n = n) !--- Parse <key>=<val> pairs
284	tt = dBase(ndb)%trac(:)
285	tmp%name = s(1); tmp%component=secn; tmp%keys = keys_type(s(1), s(2:n), v(2:n))
286	dBase(ndb)%trac = [tt(:), tmp]
287	DEALLOCATE(tt)
288	! dBase(ndb)%trac = [dBase(ndb)%trac(:), tra(name=s(1), comp=secn, keys=keys_type(s(1), s(2:n), v(2:n)))]
289	END IF
290	END DO
291	CLOSE(90)
292
293	END SUBROUTINE readSections_all
294	!------------------------------------------------------------------------------------------------------------------------------
295
296	END FUNCTION readSections
297	!==============================================================================================================================
298
299
300	!==============================================================================================================================
301	SUBROUTINE addDefault(t, defName)
302	!------------------------------------------------------------------------------------------------------------------------------
303	! Purpose: Add the keys from virtual tracer named "defName" (if any) and remove this virtual tracer.
304	!------------------------------------------------------------------------------------------------------------------------------
305	TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:)
306	CHARACTER(LEN=*), INTENT(IN) :: defName
307	INTEGER :: jd, it, k
308	TYPE(keys_type), POINTER :: ky
309	TYPE(trac_type), ALLOCATABLE :: tt(:)
310	jd = strIdx(t(:)%name, defName)
311	IF(jd == 0) RETURN
312	ky => t(jd)%keys
313	DO k = 1, SIZE(ky%key) !--- Loop on the keys of the tracer named "defName"
314	CALL addKey_m(ky%key(k), ky%val(k), t(:)%keys) !--- Add key to all the tracers (no overwriting)
315	END DO
316	tt = [t(1:jd-1),t(jd+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t) !--- Remove the virtual tracer named "defName"
317	END SUBROUTINE addDefault
318	!==============================================================================================================================
319
320	!==============================================================================================================================
321	SUBROUTINE subDefault(t, defName, lSubLocal)
322	!------------------------------------------------------------------------------------------------------------------------------
323	! Purpose: Substitute the keys from virtual tracer named "defName" (if any) and remove this virtual tracer.
324	! Substitute the keys locally (for the current tracer) if the flag "lSubLocal" is .TRUE.
325	!------------------------------------------------------------------------------------------------------------------------------
326	TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:)
327	CHARACTER(LEN=*), INTENT(IN) :: defName
328	LOGICAL, INTENT(IN) :: lSubLocal
329	INTEGER :: i0, it, ik
330	TYPE(keys_type), POINTER :: k0, ky
331	TYPE(trac_type), ALLOCATABLE :: tt(:)
332	i0 = strIdx(t(:)%name, defName)
333	IF(i0 == 0) RETURN
334	k0 => t(i0)%keys
335	DO it = 1, SIZE(t); IF(it == i0) CYCLE !--- Loop on the tracers
336	ky => t(it)%keys
337
338	!--- Substitute in the values of <key>=<val> pairs the keys defined in the virtual tracer "defName"
339	DO ik = 1, SIZE(k0%key); CALL strReplace(ky%val, k0%key(ik), k0%val(ik), .TRUE.); END DO
340
341	IF(.NOT.lSubLocal) CYCLE
342	!--- Substitute in the values of <key>=<val> pairs the keys defined locally (in the current tracer)
343	DO ik = 1, SIZE(ky%key); CALL strReplace(ky%val, ky%key(ik), ky%val(ik), .TRUE.); END DO
344	END DO
345	tt = [t(1:i0-1),t(i0+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t) !--- Remove the virtual tracer named "defName"
346
347	END SUBROUTINE subDefault
348	!==============================================================================================================================
349
350
351	!==============================================================================================================================
352	LOGICAL FUNCTION expandSection(tr, sname, fname) RESULT(lerr)
353	!------------------------------------------------------------------------------------------------------------------------------
354	! Purpose: Expand tracers and parents lists in the tracers descriptor "tra".
355	! Note: * The following keys are expanded, so are accessible explicitely using "%" operator: "parent" "type".
356	! * Default values are provided for these keys because they are necessary.
357	!------------------------------------------------------------------------------------------------------------------------------
358	TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector
359	CHARACTER(LEN=*), INTENT(IN) :: sname
360	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname
361	TYPE(trac_type), ALLOCATABLE :: ttr(:)
362	CHARACTER(LEN=maxlen), ALLOCATABLE :: ta(:), pa(:)
363	CHARACTER(LEN=maxlen) :: msg1, modname
364	INTEGER :: it, nt, iq, nq, itr, ntr, ipr, npr, i
365	LOGICAL :: ll
366	modname = 'expandSection'
367	lerr = .FALSE.
368	nt = SIZE(tr)
369	nq = 0
370	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
371	DO it = 1, nt !=== GET TRACERS NB AFTER EXPANSION + NEEDED KEYS (name, parent, type)
372	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
373	!--- Extract useful keys: parent name, type, component name
374	tr(it)%parent = fgetKey(it, 'parent', tr(:)%keys, tran0 )
375	tr(it)%type = fgetKey(it, 'type' , tr(:)%keys, 'tracer')
376	tr(it)%component = sname
377
378	!--- Determine the number of tracers and parents ; coherence checking
379	ll = strCount(tr(it)%name, ',', ntr)
380	ll = strCount(tr(it)%parent, ',', npr)
381
382	!--- Tagging tracers only can have multiple parents
383	IF(test(npr/=1 .AND. TRIM(tr(it)%type)/='tag', lerr)) THEN
384	msg1 = 'Check section "'//TRIM(sname)//'"'
385	IF(PRESENT(fname)) msg1=TRIM(msg1)//' in file "'//TRIM(fname)//'"'
386	CALL msg(TRIM(msg1)//': "'//TRIM(tr(it)%name)//'" has several parents but is not a tag', modname); RETURN
387	END IF
388	nq = nq + ntr*npr
389	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
390	END DO
391	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
392	CALL delKey(['parent','type '], tr)
393
394	ALLOCATE(ttr(nq))
395	iq = 1
396	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
397	DO it = 1, nt !=== EXPAND TRACERS AND PARENTS NAMES LISTS
398	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
399	ll = strParse(tr(it)%name, ',', ta, n=ntr) !--- Number of tracers
400	ll = strParse(tr(it)%parent, ',', pa, n=npr) !--- Number of parents
401	DO ipr=1,npr !--- Loop on parents list elts
402	DO itr=1,ntr !--- Loop on tracers list elts
403	i = iq+itr-1+(ipr-1)*ntr
404	ttr(i)%name = TRIM(ta(itr)); ttr(i)%parent = pa(ipr)
405	ttr(i)%keys = keys_type(ta(itr), tr(it)%keys%key, tr(it)%keys%val)
406	END DO
407	END DO
408	ttr(iq:iq+ntr*npr-1)%type = tr(it)%type !--- Duplicating type
409	iq = iq + ntr*npr
410	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
411	END DO
412	!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
413	DEALLOCATE(ta,pa)
414	CALL MOVE_ALLOC(FROM=ttr, TO=tr)
415
416	END FUNCTION expandSection
417	!==============================================================================================================================
418
419	!==============================================================================================================================
420	SUBROUTINE setGeneration(tr)
421	!------------------------------------------------------------------------------------------------------------------------------
422	! Purpose: Determine, for each tracer of "tr(:)":
423	! * the generation number
424	! * the first generation ancestor name
425	!------------------------------------------------------------------------------------------------------------------------------
426	! Arguments:
427	TYPE(trac_type), INTENT(INOUT) :: tr(:) !--- Tracer derived type vector
428	!------------------------------------------------------------------------------------------------------------------------------
429	! Local variables:
430	INTEGER :: iq, nq, ig
431	LOGICAL, ALLOCATABLE :: lg(:)
432	CHARACTER(LEN=maxlen), ALLOCATABLE :: prn(:)
433	!------------------------------------------------------------------------------------------------------------------------------
434	tr(:)%iGeneration = 0 !--- error if 0
435	nq = SIZE(tr, DIM=1) !--- Number of tracers lines
436	lg = tr(:)%parent == tran0 !--- First generation tracers flag
437	WHERE(lg) tr(:)%iGeneration = 1 !--- First generation tracers
438
439	!=== Determine generation for each tracer
440	ig=0; prn = [tran0]
441	DO !--- Update current generation flag
442	IF(ig/=0) prn = PACK( tr(:)%name, MASK=tr(:)%iGeneration == ig)
443	lg(:) = [(ANY(prn(:) == tr(iq)%parent), iq=1, nq)] !--- Current generation tracers flag
444	IF( ALL( .NOT. lg ) ) EXIT !--- Empty current generation
445	ig = ig+1; WHERE(lg) tr(:)%iGeneration = ig
446	END DO
447	tr(:)%gen0Name = ancestor(tr) !--- First generation ancestor name
448
449	END SUBROUTINE setGeneration
450	!==============================================================================================================================
451
452	!==============================================================================================================================
453	LOGICAL FUNCTION checkTracers(tr, sname, fname) RESULT(lerr)
454	!------------------------------------------------------------------------------------------------------------------------------
455	! Purpose:
456	! * check for orphan tracers (without known parent)
457	! * check wether the phases are known or not ("g"aseous, "l"iquid or "s"olid so far)
458	!------------------------------------------------------------------------------------------------------------------------------
459	TYPE(trac_type), INTENT(IN) :: tr(:) !--- Tracer derived type vector
460	CHARACTER(LEN=*), INTENT(IN) :: sname !--- Section name
461	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- File name
462	CHARACTER(LEN=maxlen) :: mesg
463	CHARACTER(LEN=maxlen) :: bp(SIZE(tr, DIM=1)), pha !--- Bad phases list, phases of current tracer
464	CHARACTER(LEN=1) :: p
465	INTEGER :: ip, np, iq, nq
466	!------------------------------------------------------------------------------------------------------------------------------
467	nq = SIZE(tr,DIM=1) !--- Number of tracers lines
468	mesg = 'Check section "'//TRIM(sname)//'"'
469	IF(PRESENT(fname)) mesg=TRIM(mesg)//' in file "'//TRIM(fname)//'"'
470
471	!=== CHECK FOR ORPHAN TRACERS
472	IF(test(checkList(tr%name, tr%iGeneration==0, mesg, 'tracers', 'orphan'), lerr)) RETURN
473
474	!=== CHECK PHASES
475	DO iq=1,nq; IF(tr(iq)%iGeneration/=1) CYCLE !--- Generation 1 only is checked
476	pha = fgetKey(iq, 'phases', tr(:)%keys, 'g') !--- Phases
477	np = LEN_TRIM(pha); bp(iq)=' '
478	DO ip=1,np; p = pha(ip:ip); IF(INDEX(known_phases,p)==0) bp(iq) = TRIM(bp(iq))//p; END DO
479	IF(TRIM(bp(iq)) /= '') bp(iq) = TRIM(tr(iq)%name)//': '//TRIM(bp(iq))
480	END DO
481	lerr = checkList(bp, tr%iGeneration==1 .AND. bp/='', mesg, 'tracers phases', 'unknown')
482	END FUNCTION checkTracers
483	!==============================================================================================================================
484
485	!==============================================================================================================================
486	LOGICAL FUNCTION checkUnique(tr, lTag, sname, fname) RESULT(lerr)
487	!------------------------------------------------------------------------------------------------------------------------------
488	! Purpose: Make sure that tracers are not repeated.
489	!------------------------------------------------------------------------------------------------------------------------------
490	TYPE(trac_type), INTENT(IN) :: tr(:) !--- Tracer derived type vector
491	LOGICAL, INTENT(IN) :: lTag(:) !--- Tagging tracer flag
492	CHARACTER(LEN=*), INTENT(IN) :: sname !--- Section name
493	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- File name
494	!------------------------------------------------------------------------------------------------------------------------------
495	INTEGER :: ip, np, iq, nq, k
496	LOGICAL, ALLOCATABLE :: ll(:)
497	CHARACTER(LEN=maxlen) :: mesg, tnam, tdup(SIZE(tr,DIM=1))
498	CHARACTER(LEN=1) :: p
499	!------------------------------------------------------------------------------------------------------------------------------
500	mesg = 'Check section "'//TRIM(sname)//'"'
501	IF(PRESENT(fname)) mesg=TRIM(mesg)//' in file "'//TRIM(fname)//'"'
502	nq=SIZE(tr,DIM=1); lerr=.FALSE. !--- Number of lines ; error flag
503	tdup(:) = ''
504	DO iq=1,nq; IF(lTag(iq)) CYCLE !--- Tags can be repeated
505	tnam = TRIM(tr(iq)%name)
506	ll = tr(:)%name==TRIM(tnam) !--- Mask for current tracer name
507	IF(COUNT(ll)==1 ) CYCLE !--- Tracer is not repeated
508	IF(tr(iq)%iGeneration>1) THEN
509	tdup(iq) = tnam !--- gen>1: MUST be unique
510	ELSE
511	DO ip=1,nphases; p=known_phases(ip:ip) !--- Loop on known phases
512	!--- Number of appearances of the current tracer with known phase "p"
513	np = COUNT( PACK( [(INDEX(fgetKey(k, 'phases', tr(:)%keys, 'g'),p), k=1, nq)] /=0 , MASK=ll ) )
514	IF(np <=1) CYCLE
515	tdup(iq) = TRIM(tdup(iq))//TRIM(phases_names(ip))
516	IF(ANY(tdup(1:iq-1) == tdup(iq))) tdup(iq)='' !--- Avoid repeating same messages
517	END DO
518	END IF
519	IF(tdup(iq) /= '') tdup(iq)=TRIM(tnam)//' in '//TRIM(tdup(iq))//' phase(s)'
520	END DO
521	lerr = checkList(tdup, tdup/='', mesg, 'tracers', 'duplicated')
522	END FUNCTION checkUnique
523	!==============================================================================================================================
524
525	!==============================================================================================================================
526	SUBROUTINE expandPhases(tr)
527	!------------------------------------------------------------------------------------------------------------------------------
528	! Purpose: Expand the phases in the tracers descriptor "tr".
529	!------------------------------------------------------------------------------------------------------------------------------
530	TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector
531	!------------------------------------------------------------------------------------------------------------------------------
532	TYPE(trac_type), ALLOCATABLE :: ttr(:)
533	INTEGER, ALLOCATABLE :: i0(:)
534	CHARACTER(LEN=maxlen) :: nam, pha, trn
535	INTEGER :: ip, np, iq, jq, nq, it, nt, nc, i, n
536	LOGICAL :: lTg, lEx
537	!------------------------------------------------------------------------------------------------------------------------------
538	nq = SIZE(tr, DIM=1)
539	nt = 0
540	DO iq = 1, nq !--- GET THE NUMBER OF TRACERS
541	IF(tr(iq)%iGeneration /= 1) CYCLE
542	nc = COUNT(tr(:)%gen0Name==tr(iq)%name .AND. tr%iGeneration/=1) !--- Number of childs of tr(iq)
543	tr(iq)%phase = fgetKey(iq, 'phases', tr(:)%keys) !--- Phases list of tr(iq)
544	np = LEN_TRIM(tr(iq)%phase) !--- Number of phases of tr(iq)
545	nt = nt + (1+nc) * np !--- Number of tracers after expansion
546	END DO
547	ALLOCATE(ttr(nt))
548	it = 1 !--- Current "ttr(:)" index
549	DO iq = 1, nq !--- Loop on "tr(:)" indexes
550	lTg = tr(iq)%type=='tag' !--- Current tracer is a tag
551	i0 = strFind(tr(:)%name, TRIM(tr(iq)%gen0Name), n) !--- Indexes of first generation ancestor copies
552	np = SUM( [( LEN_TRIM(tr(i0(i))%phase),i=1,n )],1) !--- Number of phases for current tracer tr(iq)
553	lEx = np>1 !--- Need of a phase suffix
554	IF(lTg) lEx=lEx.AND.tr(iq)%iGeneration>1 !--- No phase suffix for first generation tags
555	DO i=1,n !=== LOOP ON FIRST GENERATION ANCESTORS
556	jq=i0(i) !--- tr(jq): ith copy of 1st gen. ancestor of tr(iq)
557	IF(tr(iq)%iGeneration==1) jq=iq !--- Generation 1: current tracer phases only
558	pha = tr(jq)%phase !--- Phases list for tr(jq)
559	DO ip=1,LEN_TRIM(pha) !=== LOOP ON PHASES LISTS
560	trn=TRIM(tr(iq)%name); nam=trn !--- Tracer name (regular case)
561	IF(lTg) nam = TRIM(tr(iq)%parent) !--- Parent name (tagging case)
562	IF(lEx) nam = TRIM(nam)//phases_sep//pha(ip:ip) !--- Phase extension needed
563	IF(lTg) nam = TRIM(nam)//'_'//TRIM(trn) !--- <parent>_<name> for tags
564	ttr(it) = tr(iq) !--- Same <key>=<val> pairs
565	ttr(it)%name = TRIM(nam) !--- Name with possibly phase suffix
566	ttr(it)%keys%name = TRIM(nam) !--- Name inside the keys decriptor
567	ttr(it)%phase = pha(ip:ip) !--- Single phase entry
568	IF(lEx.AND.tr(iq)%iGeneration>1) THEN
569	ttr(it)%parent = TRIM(ttr(it)%parent)//phases_sep//pha(ip:ip)
570	ttr(it)%gen0Name = TRIM(ttr(it)%gen0Name)//phases_sep//pha(ip:ip)
571	END IF
572	it=it+1
573	END DO
574	IF(tr(iq)%iGeneration==1) EXIT !--- Break phase loop for gen 1
575	END DO
576	END DO
577	CALL MOVE_ALLOC(FROM=ttr, TO=tr)
578	CALL delKey(['phases'],tr) !--- Remove few keys entries
579
580	END SUBROUTINE expandPhases
581	!==============================================================================================================================
582
583	!==============================================================================================================================
584	SUBROUTINE sortTracers(tr)
585	!------------------------------------------------------------------------------------------------------------------------------
586	! Purpose: Sort tracers:
587	! * lGrowGen == T: in ascending generations numbers.
588	! * lGrowGen == F: tracer + its childs sorted by growing generation, one after the other.
589	!------------------------------------------------------------------------------------------------------------------------------
590	TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector
591	INTEGER :: ig, ng, iq, jq, n, ix(SIZE(tr)), k
592	INTEGER, ALLOCATABLE :: iy(:), iz(:)
593	!------------------------------------------------------------------------------------------------------------------------------
594	iq = 1
595	IF(lSortByGen) THEN
596	ng = MAXVAL(tr(:)%iGeneration, MASK=.TRUE., DIM=1) !--- Number of generations
597	DO ig = 0, ng !--- Loop on generations
598	iy = PACK([(k, k=1, SIZE(tr))], MASK=tr(:)%iGeneration==ig) !--- Generation ig tracers indexes
599	n = SIZE(iy)
600	ix(iq:iq+n-1) = iy !--- Stack growing generations idxs
601	iq = iq + n
602	END DO
603	ELSE
604	DO jq = 1, SIZE(tr,DIM=1) !--- Loop on first generation tracers
605	IF(tr(jq)%iGeneration /= 1) CYCLE !--- Skip generations >= 1
606	ix(iq) = jq !--- First generation ancestor index first
607	iq = iq + 1
608	iy = strFind(tr(:)%gen0Name, TRIM(tr(jq)%name)) !--- Indexes of "tr(jq)" childs in "tr(:)"
609	ng = MAXVAL(tr(iy)%iGeneration, MASK=.TRUE., DIM=1) !--- Generations number of the "tr(jq)" family
610	DO ig = 2, ng !--- Loop on generations for the tr(jq) family
611	iz = find(tr(iy)%iGeneration, ig, n) !--- Indexes of the tracers "tr(iy(:))" of generation "ig"
612	ix(iq:iq+n-1) = iy(iz) !--- Same indexes in "tr(:)"
613	iq = iq + n
614	END DO
615	END DO
616	END IF
617	tr = tr(ix) !--- Reorder the tracers
618	END SUBROUTINE sortTracers
619	!==============================================================================================================================
620
621	!==============================================================================================================================
622	LOGICAL FUNCTION mergeTracers(sections, tr) RESULT(lerr)
623	TYPE(dataBase_type), TARGET, INTENT(IN) :: sections(:)
624	TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: tr(:)
625	TYPE(trac_type), POINTER :: t1(:), t2(:)
626	INTEGER, ALLOCATABLE :: ixct(:), ixck(:)
627	INTEGER :: is, k1, k2, nk2, i1, i2, nt2
628	CHARACTER(LEN=maxlen) :: s1, v1, v2, tnam, knam, modname
629	modname = 'mergeTracers'
630	lerr = .FALSE.
631	t1 => sections(1)%trac(:) !--- Alias: first tracers section
632	tr = t1
633	!----------------------------------------------------------------------------------------------------------------------------
634	DO is=2,SIZE(sections) !=== SEVERAL SECTIONS: MERGE THEM
635	!----------------------------------------------------------------------------------------------------------------------------
636	t2 => sections(is)%trac(:) !--- Alias: current tracers section
637	nt2 = SIZE(t2(:), DIM=1) !--- Number of tracers in section
638	ixct = strIdx(t1(:)%name, t2(:)%name) !--- Indexes of common tracers
639	tr = [tr, PACK(t2, MASK= ixct==0)] !--- Append with new tracers
640	IF( ALL(ixct == 0) ) CYCLE !--- No common tracers => done
641	CALL msg('Tracers defined in previous sections and duplicated in "'//TRIM(sections(is)%name)//'":', modname)
642	CALL msg(t1(PACK(ixct, MASK = ixct/=0))%name, modname, nmax=128) !--- Display duplicates (the 128 first at most)
643	!--------------------------------------------------------------------------------------------------------------------------
644	DO i2=1,nt2; tnam = TRIM(t2(i2)%name) !=== LOOP ON COMMON TRACERS
645	!--------------------------------------------------------------------------------------------------------------------------
646	i1 = ixct(i2); IF(i1 == 0) CYCLE !--- Idx in t1(:) ; skip new tracers
647
648	!=== CHECK WETHER ESSENTIAL KEYS ARE IDENTICAL OR NOT
649	s1=' of "'//TRIM(tnam)//'" in "'//TRIM(sections(is)%name)//'" not matching previous value'
650
651	IF(test(fmsg('Parent name'//TRIM(s1), modname, t1(i1)%parent /= t2(i2)%parent), lerr)) RETURN
652	IF(test(fmsg('Type' //TRIM(s1), modname, t1(i1)%type /= t2(i2)%type), lerr)) RETURN
653	IF(test(fmsg('Generation' //TRIM(s1), modname, t1(i1)%iGeneration /= t2(i2)%iGeneration), lerr)) RETURN
654
655	!=== APPEND <key>=<val> PAIRS NOT PREVIOULSLY DEFINED
656	nk2 = SIZE(t2(i2)%keys%key(:)) !--- Keys number in current section
657	ixck = strIdx(t1(i1)%keys%key(:), t2(i2)%keys%key(:)) !--- Common keys indexes
658
659	!=== APPEND NEW KEYS
660	tr(i1)%keys%key = [ tr(i1)%keys%key, PACK(tr(i2)%keys%key, MASK = ixck==0)]
661	tr(i1)%keys%val = [ tr(i1)%keys%val, PACK(tr(i2)%keys%val, MASK = ixck==0)]
662
663	!--- KEEP TRACK OF THE COMPONENTS NAMES
664	tr(i1)%component = TRIM(tr(i1)%component)//','//TRIM(tr(i2)%component)
665
666	!--- SELECT COMMON TRACERS WITH DIFFERING KEYS VALUES (PREVIOUS VALUE IS KEPT)
667	DO k2=1,nk2
668	k1 = ixck(k2); IF(k1 == 0) CYCLE
669	IF(t1(i1)%keys%val(k1) == t2(i2)%keys%val(k2)) ixck(k2)=0
670	END DO
671	IF(ALL(ixck==0)) CYCLE !--- No identical keys with /=values
672
673	!--- DISPLAY INFORMATION: OLD VALUES ARE KEPT FOR THE KEYS FOUND IN PREVIOUS AND CURRENT SECTIONS
674	CALL msg('Key(s)'//TRIM(s1), modname)
675	DO k2 = 1, nk2 !--- Loop on keys found in both t1(:) and t2(:)
676	knam = t2(i2)%keys%key(k2) !--- Name of the current key
677	k1 = ixck(k2) !--- Corresponding index in t1(:)
678	IF(k1 == 0) CYCLE !--- New keys are skipped
679	v1 = t1(i1)%keys%val(k1); v2 = t2(i2)%keys%val(k2) !--- Key values in t1(:) and t2(:)
680	CALL msg(' * '//TRIM(knam)//'='//TRIM(v2)//' ; previous value kept:'//TRIM(v1), modname)
681	END DO
682	!------------------------------------------------------------------------------------------------------------------------
683	END DO
684	!--------------------------------------------------------------------------------------------------------------------------
685	END DO
686	CALL sortTracers(tr)
687
688	END FUNCTION mergeTracers
689	!==============================================================================================================================
690
691	!==============================================================================================================================
692	LOGICAL FUNCTION cumulTracers(sections, tr) RESULT(lerr)
693	TYPE(dataBase_type), TARGET, INTENT(IN) :: sections(:)
694	TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: tr(:)
695	TYPE(trac_type), POINTER :: t1(:), t2(:)
696	INTEGER, ALLOCATABLE :: nt(:)
697	CHARACTER(LEN=maxlen) :: tnam, tnam_new
698	INTEGER :: iq, nq, is, ns, nsec
699	lerr = .FALSE. !--- Can't fail ; kept to match "mergeTracer" interface.
700	nsec = SIZE(sections)
701	tr = [( sections(is)%trac(:) , is=1, nsec )] !--- Concatenated tracers vector
702	nt = [( SIZE(sections(is)%trac(:)), is=1, nsec )] !--- Number of tracers in each section
703	!----------------------------------------------------------------------------------------------------------------------------
704	DO is=1, nsec !=== LOOP ON SECTIONS
705	!----------------------------------------------------------------------------------------------------------------------------
706	t1 => sections(is)%trac(:)
707	!--------------------------------------------------------------------------------------------------------------------------
708	DO iq=1, nt(is) !=== LOOP ON TRACERS
709	!--------------------------------------------------------------------------------------------------------------------------
710	tnam = TRIM(t1(iq)%name) !--- Original name
711	IF(COUNT(t1%name == tnam) == 1) CYCLE !--- Current tracer is not duplicated: finished
712	tnam_new = TRIM(tnam)//phases_sep//TRIM(sections(is)%name) !--- Same with section extension
713	nq = SUM(nt(1:is-1)) !--- Number of tracers in previous sections
714	ns = nt(is) !--- Number of tracers in the current section
715	tr(iq + nq)%name = TRIM(tnam_new) !--- Modify tracer name
716	WHERE(tr(1+nq:ns+nq)%parent==tnam) tr(1+nq:ns+nq)%parent=tnam_new !--- Modify parent name
717	!--------------------------------------------------------------------------------------------------------------------------
718	END DO
719	!----------------------------------------------------------------------------------------------------------------------------
720	END DO
721	!----------------------------------------------------------------------------------------------------------------------------
722	CALL sortTracers(tr)
723	END FUNCTION cumulTracers
724	!==============================================================================================================================
725
726	!==============================================================================================================================
727	SUBROUTINE setDirectKeys(tr)
728	TYPE(trac_type), INTENT(INOUT) :: tr(:)
729	CALL indexUpdate(tr) !--- Update iqParent and iqDescen indexes vectors
730	! DO iq = 1, SIZE(tr)
731	! tr(iq)%keys%<key> = getKey_prv(it, "<key>", tr%keys, tran0 ) !--- For additional keys
732	! END DO
733	END SUBROUTINE setDirectKeys
734	!==============================================================================================================================
735
736	!==============================================================================================================================
737	LOGICAL FUNCTION dispTraSection(message, sname, modname) RESULT(lerr)
738	CHARACTER(LEN=*), INTENT(IN) :: message, sname, modname
739	INTEGER :: idb, iq, nq
740	INTEGER, ALLOCATABLE :: hadv(:), vadv(:)
741	TYPE(trac_type), POINTER :: tm(:)
742	lerr = .FALSE.
743	idb = strIdx(dBase(:)%name, sname); IF(idb == 0) RETURN
744	tm => dBase(idb)%trac
745	nq = SIZE(tm)
746	IF(test(getKeyByName_im('hadv', hadv, tm(:)%name, tm(:)%keys),lerr)) RETURN
747	IF(test(getKeyByName_im('vadv', vadv, tm(:)%name, tm(:)%keys),lerr)) RETURN
748	CALL msg(TRIM(message)//':', modname)
749	IF(test(dispTable('iiissis', ['iq ','hadv ','vadv ','short name','parent ','igen ','phase '], &
750	cat(tm(:)%name, tm(:)%parent, tm(:)%phase), cat([(iq, iq=1, nq)], hadv, vadv, tm(:)%iGeneration)), lerr)) RETURN
751	END FUNCTION dispTraSection
752	!==============================================================================================================================
753	!==============================================================================================================================
754
755
756	!==============================================================================================================================
757	!== CREATE A SCALAR ALIAS OF THE COMPONENT OF THE TRACERS DESCRIPTOR "t" NAMED "tname" ========================================
758	!==============================================================================================================================
759	FUNCTION aliasTracer(tname, t) RESULT(out)
760	TYPE(trac_type), POINTER :: out
761	CHARACTER(LEN=*), INTENT(IN) :: tname
762	TYPE(trac_type), TARGET, INTENT(IN) :: t(:)
763	INTEGER :: it
764	it = strIdx(t(:)%name, tname)
765	out => NULL(); IF(it /= 0) out => t(it)
766	END FUNCTION aliasTracer
767	!------------------------------------------------------------------------------------------------------------------------------
768
769
770	!==============================================================================================================================
771	!=== FROM A LIST OF INDEXES OR NAMES, CREATE A SUBSET OF THE TRACERS DESCRIPTORS LIST "trac" ==================================
772	!==============================================================================================================================
773	FUNCTION trSubset_Indx(trac,idx) RESULT(out)
774	TYPE(trac_type), ALLOCATABLE :: out(:)
775	TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:)
776	INTEGER, INTENT(IN) :: idx(:)
777	out = trac(idx)
778	CALL indexUpdate(out)
779	END FUNCTION trSubset_Indx
780	!------------------------------------------------------------------------------------------------------------------------------
781	FUNCTION trSubset_Name(trac,nam) RESULT(out)
782	TYPE(trac_type), ALLOCATABLE :: out(:)
783	TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:)
784	CHARACTER(LEN=*), INTENT(IN) :: nam(:)
785	out = trac(strIdx(trac(:)%name, nam))
786	CALL indexUpdate(out)
787	END FUNCTION trSubset_Name
788	!------------------------------------------------------------------------------------------------------------------------------
789
790
791	!==============================================================================================================================
792	!=== CREATE THE SUBSET OF THE TRACERS DESCRIPTORS LIST "trac" HAVING THE FIRST GENERATION ANCESTOR NAMED "nam" ================
793	!==============================================================================================================================
794	FUNCTION trSubset_gen0Name(trac,nam) RESULT(out)
795	TYPE(trac_type), ALLOCATABLE :: out(:)
796	TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:)
797	CHARACTER(LEN=*), INTENT(IN) :: nam
798	out = trac(strFind(delPhase(trac(:)%gen0Name), nam))
799	CALL indexUpdate(out)
800	END FUNCTION trSubset_gen0Name
801	!------------------------------------------------------------------------------------------------------------------------------
802
803
804	!==============================================================================================================================
805	!=== UPDATE THE INDEXES iqParent, iqDescend AND iGeneration IN THE TRACERS DESCRIPTOR LIST "tr" (USEFULL FOR SUBSETS) =========
806	!==============================================================================================================================
807	SUBROUTINE indexUpdate(tr)
808	TYPE(trac_type), INTENT(INOUT) :: tr(:)
809	INTEGER :: iq, ig, ng, ngen
810	INTEGER, ALLOCATABLE :: ix(:)
811	tr(:)%iqParent = strIdx( tr(:)%name, tr(:)%parent ) !--- Parent index
812	ngen = MAXVAL(tr(:)%iGeneration, MASK=.TRUE.)
813	DO iq = 1, SIZE(tr)
814	ng = tr(iq)%iGeneration !--- Generation of the current tracer
815	ix = idxAncestor(tr, igen = ng); ix = PACK(ix, ix/=0) !--- Indexes of the tracers with ancestor tr(iq)
816	!--- Childs indexes in growing generation order
817	tr(iq)%iqDescen = [( PACK(ix, MASK = tr(ix)%iGeneration == ig), ig = ng+1, ngen)]
818	tr(iq)%nqDescen = SUM( [( COUNT(tr(ix)%iGeneration == ig), ig = ng+1, ngen)] )
819	tr(iq)%nqChilds = COUNT(tr(ix)%iGeneration == ng+1)
820	END DO
821	END SUBROUTINE indexUpdate
822	!------------------------------------------------------------------------------------------------------------------------------
823
824
825	!==============================================================================================================================
826	!=== READ FILE "fnam" TO APPEND THE "dBase" TRACERS DATABASE WITH AS MUCH SECTIONS AS PARENTS NAMES IN "isot(:)%parent": ====
827	!=== * Each section dBase(i)%name contains the isotopes "dBase(i)%trac(:)" descending on "dBase(i)%name"="iso(i)%parent" ====
828	!=== * For each isotopes class, the <key>=<val> vector of each tracer is moved into the isotopes descriptor "isot" ====
829	!=== NOTES: ====
830	!=== * Most of the "isot" components have been defined in the calling routine (initIsotopes): ====
831	!=== prnt, nzon, zone(:), niso, keys(:)%name, nitr, trac(:), npha, phas, iTraPha(:,:), iZonPhi(:,:) ====
832	!=== * Same syntax for isotopes file and "tracer.def": a tracers section contains one line for each of its isotopes ====
833	!=== * Each tracers section can contain a "params" virtual isotope line of isotopes parameters default values ====
834	!=== * In case keys are found both in the "params" section and the "*.def" file, the later value is retained ====
835	!=== * On each isotope line, defined keys can be used for other keys defintions (single level depth substitution) ====
836	!=== * The routine gives an error if a required isotope is not available in the database stored in "fnam" ====
837	!==============================================================================================================================
838	LOGICAL FUNCTION readIsotopesFile(fnam, isot) RESULT(lerr)
839	CHARACTER(LEN=*), INTENT(IN) :: fnam !--- Input file name
840	TYPE(isot_type), TARGET, INTENT(INOUT) :: isot(:) !--- Isotopes descriptors (field "prnt" must be defined !)
841	INTEGER :: ik, is, it, idb, nk0, i, iis
842	INTEGER :: nk, ns, nt, ndb, nb0, i0
843	CHARACTER(LEN=maxlen), POINTER :: k(:), v(:), k0(:), v0(:)
844	CHARACTER(LEN=maxlen), ALLOCATABLE :: vals(:)
845	CHARACTER(LEN=maxlen) :: val, modname
846	TYPE(keys_type), POINTER :: ky(:)
847	TYPE(trac_type), POINTER :: tt(:), t
848	TYPE(dataBase_type), ALLOCATABLE :: tdb(:)
849	LOGICAL, ALLOCATABLE :: liso(:)
850	modname = 'readIsotopesFile'
851
852	!--- THE INPUT FILE MUST BE PRESENT
853	IF(test(fmsg('Missing isotopes parameters file "'//TRIM(fnam)//'"', modname, testFile(fnam)),lerr)) RETURN
854
855	!--- READ THE FILE SECTIONS, ONE EACH PARENT TRACER
856	nb0 = SIZE(dBase, DIM=1)+1 !--- Next database element index
857	IF(test(readSections(fnam,strStack(isot(:)%parent,',')),lerr)) RETURN !--- Read sections, one each parent tracer
858	ndb = SIZE(dBase, DIM=1) !--- Current database size
859	DO idb = nb0, ndb
860	iis = idb-nb0+1
861
862	!--- GET FEW GLOBAL KEYS FROM "def" FILES AND ADD THEM TO THE 'params' SECTION
863	CALL addKeysFromDef(dBase(idb)%trac, 'params')
864
865	!--- SUBSTITUTE THE KEYS DEFINED IN THE 'params' VIRTUAL TRACER ; SUBSTITUTE LOCAL KEYS ; REMOVE 'params' VIRTUAL TRACER
866	CALL subDefault(dBase(idb)%trac, 'params', .TRUE.)
867
868	tt => dBase(idb)%trac
869
870	!--- REDUCE THE EXPRESSIONS TO OBTAIN SCALARS AND TRANSFER THEM TO THE "isot" ISOTOPES DESCRIPTORS VECTOR
871	DO it = 1, SIZE(dBase(idb)%trac)
872	t => dBase(idb)%trac(it)
873	is = strIdx(isot(iis)%keys(:)%name, t%name) !--- Index in "isot(iis)%keys(:)%name" of isotope "t%name"
874	IF(is == 0) CYCLE
875	liso = reduceExpr(t%keys%val, vals) !--- Reduce expressions (for substituted variables)
876	IF(test(ANY(liso), lerr)) RETURN !--- Some non-numerical elements were found
877	isot(iis)%keys(is)%key = PACK(t%keys%key, MASK=.NOT.liso)
878	isot(iis)%keys(is)%val = PACK( vals, MASK=.NOT.liso)
879	END DO
880
881	!--- CHECK FOR MISSING ISOTOPES (NO KEYS ALLOCATED)
882	liso = [( ALLOCATED(isot(iis)%keys(is)%key), is=1, SIZE(isot(iis)%keys) )]
883	IF(test(checkList(isot(iis)%keys(:)%name, .NOT.liso, &
884	'Check file "'//TRIM(fnam)//'" in section "'//TRIM(dBase(idb)%name)//'"', 'isotopes', 'missing'),lerr)) RETURN
885	END DO
886
887	!--- CLEAN THE DATABASE ENTRIES
888	IF(nb0 == 1) THEN
889	DEALLOCATE(dBase); ALLOCATE(dBase(0))
890	ELSE
891	ALLOCATE(tdb(nb0-1)); tdb(1:nb0-1)=dBase(1:nb0-1); CALL MOVE_ALLOC(FROM=tdb, TO=dBase)
892	END IF
893	lerr = dispIsotopes(isot, 'Isotopes parameters read from file', modname)
894
895	END FUNCTION readIsotopesFile
896	!==============================================================================================================================
897
898	!==============================================================================================================================
899	!=== IF ISOTOPES (2ND GENERATION TRACERS) ARE DETECTED: ===
900	!=== * COMPUTE MOST OF THE RELATED QUANTITIES ("isot" COMPONENTS). ===
901	!=== * COMPUTE FEW ISOTOPES-DEDICATED "trac" COMPONENTS ===
902	!=== * CALL readIsotopesFile TO GET PHYSICAL QUANTITIES (<key>=<val> PAIRS) ===
903	!=== NOTE: THIS IS DONE HERE (IN A ROUTINE CALLED BY THE DYNAMIC), BECAUSE THE DYNAMIC NEEDS FEW PHYSICAL PARAMETERS. ===
904	!==============================================================================================================================
905	SUBROUTINE initIsotopes(trac, isot)
906	TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: trac(:)
907	TYPE(isot_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: isot(:)
908	CHARACTER(LEN=maxlen), ALLOCATABLE :: p(:), str(:) !--- Temporary storage
909	CHARACTER(LEN=maxlen) :: iname
910	CHARACTER(LEN=1) :: ph !--- Phase
911	INTEGER :: nbIso, ic, ip, iq, it, iz
912	LOGICAL, ALLOCATABLE :: ll(:) !--- Mask
913	TYPE(trac_type), POINTER :: t(:), t1
914	TYPE(isot_type), POINTER :: s
915
916	t => trac
917
918	p = PACK(delPhase(t%parent), MASK = t%type=='tracer' .AND. t%iGeneration==2) !--- Parents of 2nd generation isotopes
919	CALL strReduce(p, nbIso)
920	ALLOCATE(isot(nbIso))
921
922	IF(nbIso==0) RETURN !=== NO ISOTOPES: FINISHED
923
924	!--- ISOTOPES RELATED VARIABLES ; NULL OR EMPTY IF NO ISOTOPES
925	isot(:)%parent = p
926	DO ic = 1, SIZE(p) !--- Loop on isotopes classes
927	s => isot(ic)
928	iname = s%parent !--- Current isotopes class name (parent tracer name)
929
930	!=== Isotopes childs of tracer "iname": mask, names, number (same for each phase of "iname")
931	ll = t(:)%type=='tracer' .AND. delPhase(t(:)%parent) == iname .AND. t(:)%phase == 'g'
932	str = PACK(delPhase(t(:)%name), MASK = ll) !--- Effectively found isotopes of "iname"
933	s%niso = SIZE(str) !--- Number of "effectively found isotopes of "iname"
934	ALLOCATE(s%keys(s%niso))
935	FORALL(it = 1:s%niso) s%keys(it)%name = str(it)
936
937	!=== Geographic tagging tracers descending on tracer "iname": mask, names, number
938	ll = t(:)%type=='tag' .AND. delPhase(t(:)%gen0Name) == iname .AND. t(:)%iGeneration == 3
939	s%zone = PACK(strTail(t(:)%name,'_',lFirst=.TRUE.), MASK = ll) !--- Tagging zones names for isotopes category "iname"
940	CALL strReduce(s%zone)
941	s%nzon = SIZE(s%zone) !--- Tagging zones number for isotopes category "iname"
942
943	!=== Geographic tracers of the isotopes childs of tracer "iname" (same for each phase of "iname")
944	! NOTE: One might like to create a similar variable for 2nd generation tagging tracers (tagging the gen1 tracers)
945	str = PACK(delPhase(t(:)%name), MASK=ll)
946	CALL strReduce(str)
947	s%nitr = s%niso + SIZE(str) !--- Number of isotopes + their geographic tracers [ntraciso]
948	ALLOCATE(s%trac(s%nitr))
949	FORALL(it = 1:s%niso) s%trac(it) = s%keys(it)%name
950	FORALL(it = s%niso+1:s%nitr) s%trac(it) = str(it-s%niso)
951
952	!=== Phases for tracer "iname"
953	s%phase = ''
954	DO ip = 1, nphases; ph = known_phases(ip:ip); IF(strIdx(t%name,addPhase(iname, ph)) /= 0) s%phase = TRIM(s%phase)//ph; END DO
955	s%npha = LEN_TRIM(s%phase) !--- Equal to "nqo" for water
956
957	!=== Tables giving the index in a table of effectively found items for each dynamical tracer (1<=iq<=nqtot)
958	DO iq = 1, SIZE(t)
959	t1 => trac(iq)
960	IF(delPhase(t1%gen0Name) /= iname) CYCLE !--- Only deal with tracers descending on "iname"
961	t1%iso_iGroup = ic !--- Isotopes family idx in list "isotopes(:)%parent"
962	t1%iso_iName = strIdx(s%trac, delPhase(strHead(t1%name,'_'))) !--- Current isotope idx in effective isotopes list
963	t1%iso_iZone = strIdx(s%zone, strTail(t1%name,'_') ) !--- Current isotope zone idx in effective zones list
964	t1%iso_iPhase = INDEX(s%phase,TRIM(t1%phase)) !--- Current isotope phase idx in effective phases list
965	IF(t1%iGeneration /= 3) t1%iso_iZone = 0 !--- Skip possible generation 2 tagging tracers
966	END DO
967
968	!=== Table used to get iq (index in dyn array, size nqtot) from the isotope and phase indexes ; the full isotopes list
969	! (including tagging tracers) is sorted this way: iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN
970	s%iTraPha = RESHAPE( [( (strIdx(t(:)%name, addPhase(s%trac(it),s%phase(ip:ip))), it=1, s%nitr), ip=1, s%npha)], &
971	[s%nitr, s%npha] )
972
973	!=== Table used to get ix (index in tagging tracers isotopes list, size nitr) from the zone and isotope indexes
974	s%iZonIso = RESHAPE( [( (strIdx(s%trac(:), TRIM(s%trac(it))//'_'//TRIM(s%zone(iz))), iz=1, s%nzon), it=1, s%niso)], &
975	[s%nzon, s%niso] )
976	END DO
977
978	!=== READ PHYSICAL PARAMETERS FROM "isotopes_params.def" FILE
979	! DONE HERE, AND NOT ONLY IN "infotrac_phy", BECAUSE SOME PHYSICAL PARAMS ARE NEEDED FOR RESTARTS (tnat AND alpha_ideal)
980	IF(readIsotopesFile('isotopes_params.def',isot)) CALL abort_gcm(modname,'Problem when reading isotopes parameters',1)
981
982	END SUBROUTINE initIsotopes
983	!==============================================================================================================================
984
985
986	!==============================================================================================================================
987	LOGICAL FUNCTION dispIsotopes(ides, message, modname) RESULT(lerr)
988	TYPE(isot_type), INTENT(IN) :: ides(:) !--- Isotopes descriptor vector
989	CHARACTER(LEN=*), INTENT(IN) :: message !--- Message to display
990	CHARACTER(LEN=*), INTENT(IN) :: modname !--- Calling subroutine name
991	INTEGER :: ik, nk, ip, it, nt
992	CHARACTER(LEN=maxlen) :: prf
993	CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:), val(:,:)
994	CALL msg(TRIM(message)//':', modname)
995	DO ip = 1, SIZE(ides) !--- Loop on parents tracers
996	nk = SIZE(ides(ip)%keys(1)%key) !--- Same keys for each isotope
997	nt = SIZE(ides(ip)%keys) !--- Number of isotopes
998	prf = 'i'//REPEAT('s',nk+1) !--- Profile for table printing
999	ALLOCATE(ttl(nk+2), val(nt,nk+1))
1000	ttl(1:2) = ['iq ','name']; ttl(3:nk+2) = ides(ip)%keys(1)%key(:)!--- Titles line with keys names
1001	val(:,1) = ides(ip)%keys(:)%name !--- Values table 1st column: isotopes names
1002	DO ik = 1, nk
1003	DO it = 1, nt
1004	val(it,ik+1) = ides(ip)%keys(it)%val(ik) !--- Other columns: keys values
1005	END DO
1006	END DO
1007	IF(test(fmsg('Problem with the table content', modname, dispTable(prf, ttl, val, cat([(it,it=1,nt)]), rFmt='(EN8.4)')), &
1008	lerr)) RETURN
1009	DEALLOCATE(ttl, val)
1010	END DO
1011	END FUNCTION dispIsotopes
1012	!==============================================================================================================================
1013
1014
1015	!==============================================================================================================================
1016	SUBROUTINE addKey_1(key, val, ky, lOverWrite)
1017	!------------------------------------------------------------------------------------------------------------------------------
1018	! Purpose: Add the <key>=<val> pair in the "ky" keys descriptor.
1019	!------------------------------------------------------------------------------------------------------------------------------
1020	CHARACTER(LEN=*), INTENT(IN) :: key, val
1021	TYPE(keys_type), INTENT(INOUT) :: ky
1022	LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite
1023	CHARACTER(LEN=maxlen), ALLOCATABLE :: k(:), v(:)
1024	INTEGER :: iky, nky
1025	LOGICAL :: lo
1026	!------------------------------------------------------------------------------------------------------------------------------
1027	lo=.FALSE.; IF(PRESENT(lOverWrite)) lo=lOverWrite
1028	iky = strIdx(ky%key,key)
1029	IF(iky == 0) THEN
1030	nky = SIZE(ky%key)
1031	IF(nky == 0) THEN; ky%key = [key]; ky%val = [val]; ELSE; ky%key = [ky%key, key]; ky%val = [ky%val, val]; END IF
1032	ELSE IF(lo) THEN !--- Overwriting
1033	ky%key(iky) = key; ky%val(iky) = val
1034	END IF
1035	END SUBROUTINE addKey_1
1036	!==============================================================================================================================
1037	SUBROUTINE addKey_m(key, val, ky, lOverWrite)
1038	!------------------------------------------------------------------------------------------------------------------------------
1039	! Purpose: Add the <key>=<val> pair in all the components of the "ky" keys descriptor.
1040	!------------------------------------------------------------------------------------------------------------------------------
1041	CHARACTER(LEN=*), INTENT(IN) :: key, val
1042	TYPE(keys_type), INTENT(INOUT) :: ky(:)
1043	LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite
1044	INTEGER :: itr
1045	LOGICAL :: lo
1046	!------------------------------------------------------------------------------------------------------------------------------
1047	lo=.FALSE.; IF(PRESENT(lOverWrite)) lo=lOverWrite
1048	DO itr = 1, SIZE(ky); CALL addKey_1(key, val, ky(itr), lo); END DO
1049	END SUBROUTINE addKey_m
1050	!==============================================================================================================================
1051	SUBROUTINE addKeysFromDef(t, tr0)
1052	!------------------------------------------------------------------------------------------------------------------------------
1053	! Purpose: The values of the keys of the tracer named "tr0" are overwritten by the values found in the *.def files, if any.
1054	!------------------------------------------------------------------------------------------------------------------------------
1055	TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: t(:)
1056	CHARACTER(LEN=*), INTENT(IN) :: tr0
1057	CHARACTER(LEN=maxlen) :: val
1058	INTEGER :: ik, jd
1059	jd = strIdx(t%name, tr0)
1060	IF(jd == 0) RETURN
1061	DO ik = 1, SIZE(t(jd)%keys%key)
1062	CALL get_in(t(jd)%keys%key(ik), val, 'zzzz')
1063	IF(val /= 'zzzz') CALL addKey_1(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.)
1064	END DO
1065	END SUBROUTINE addKeysFromDef
1066	!==============================================================================================================================
1067	SUBROUTINE delKey_1(itr, keyn, ky)
1068	!------------------------------------------------------------------------------------------------------------------------------
1069	! Purpose: Internal routine.
1070	! Remove <key>=<val> pairs in the "itr"th component of the "ky" keys descriptor.
1071	!------------------------------------------------------------------------------------------------------------------------------
1072	INTEGER, INTENT(IN) :: itr
1073	CHARACTER(LEN=*), INTENT(IN) :: keyn(:)
1074	TYPE(trac_type), INTENT(INOUT) :: ky(:)
1075	CHARACTER(LEN=maxlen), ALLOCATABLE :: k(:), v(:)
1076	LOGICAL, ALLOCATABLE :: ll(:)
1077	INTEGER :: iky
1078	!------------------------------------------------------------------------------------------------------------------------------
1079	IF(itr<=0 .OR. itr>SIZE(ky, DIM=1)) RETURN !--- Index is out of range
1080	ll = [( ALL(keyn/=ky(itr)%keys%key(iky)), iky=1, SIZE(ky(itr)%keys%key) )]
1081	k = PACK(ky(itr)%keys%key, MASK=ll); CALL MOVE_ALLOC(FROM=k, TO=ky(itr)%keys%key)
1082	v = PACK(ky(itr)%keys%val, MASK=ll); CALL MOVE_ALLOC(FROM=v, TO=ky(itr)%keys%val)
1083	END SUBROUTINE delKey_1
1084	!==============================================================================================================================
1085	SUBROUTINE delKey(keyn, ky)
1086	!------------------------------------------------------------------------------------------------------------------------------
1087	! Purpose: Internal routine.
1088	! Remove <key>=<val> pairs in all the components of the "t" tracers descriptor.
1089	!------------------------------------------------------------------------------------------------------------------------------
1090	CHARACTER(LEN=*), INTENT(IN) :: keyn(:)
1091	TYPE(trac_type), INTENT(INOUT) :: ky(:)
1092	INTEGER :: iky
1093	!------------------------------------------------------------------------------------------------------------------------------
1094	DO iky = 1, SIZE(ky); CALL delKey_1(iky, keyn, ky); END DO
1095	END SUBROUTINE delKey
1096	!==============================================================================================================================
1097
1098
1099	!==============================================================================================================================
1100	!=== PUBLIC ROUTINES: GET A KEY FROM A <key>=<val> LIST ; VECTORS, TRACER AND DATABASE VERSIONS ===============================
1101	!=== BEWARE !!! IF THE "ky" ARGUMENT IS NOT PRESENT, THEN THE VARIABLES "tracers" AND "isotopes" ARE USED. ====================
1102	!=== THEY ARE LOCAL TO THIS MODULE, SO MUST MUST BE INITIALIZED FIRST USING the "getKey_init" ROUTINE ====================
1103	!==============================================================================================================================
1104	SUBROUTINE getKey_init(tracers_, isotopes_)
1105	TYPE(trac_type), OPTIONAL, INTENT(IN) :: tracers_(:)
1106	TYPE(isot_type), OPTIONAL, INTENT(IN) :: isotopes_(:)
1107	IF(PRESENT( tracers_)) tracers = tracers_
1108	IF(PRESENT(isotopes_)) isotopes = isotopes_
1109	END SUBROUTINE getKey_init
1110	!==============================================================================================================================
1111	CHARACTER(LEN=maxlen) FUNCTION fgetKey(itr, keyn, ky, def_val) RESULT(out)
1112	!------------------------------------------------------------------------------------------------------------------------------
1113	! Purpose: Internal function ; get a key value in string format (this is the returned argument).
1114	!------------------------------------------------------------------------------------------------------------------------------
1115	INTEGER, INTENT(IN) :: itr
1116	CHARACTER(LEN=*), INTENT(IN) :: keyn
1117	TYPE(keys_type), INTENT(IN) :: ky(:)
1118	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def_val
1119	!------------------------------------------------------------------------------------------------------------------------------
1120	INTEGER :: ik
1121	ik = 0; IF(itr>0 .AND. itr<=SIZE(ky)) ik = strIdx(ky(itr)%key(:), keyn)
1122	out = ''; IF(ik /= 0) out = ky(itr)%val(ik) !--- Key was found
1123	IF(PRESENT(def_val) .AND. ik == 0) out = def_val !--- Default value from arguments
1124	END FUNCTION fgetKey
1125	!==============================================================================================================================
1126	LOGICAL FUNCTION getKeyByName_s1(keyn, val, tname, ky) RESULT(lerr)
1127	!--- Purpose: Get the value of the key named "keyn" for the tracer named "tnam".
1128	! * "ky" unspecified: try in "tracers" for "tnam" with phase and tagging suffixes, then in "isotopes" without.
1129	! * "ky" specified: try in "ky" for "tnam" with phase and tagging suffixes, then without.
1130	! The returned error code is always .FALSE.: an empty string is returned when the key hasn't been found.
1131	CHARACTER(LEN=*), INTENT(IN) :: keyn
1132	CHARACTER(LEN=maxlen), INTENT(OUT) :: val
1133	CHARACTER(LEN=*), INTENT(IN) :: tname
1134	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1135	INTEGER :: is
1136	lerr = .FALSE.
1137	IF(PRESENT(ky)) THEN
1138	val = getKeyByName_prv(keyn, tname , ky); IF(val /= '') RETURN !--- "ky" and "tnam"
1139	val = getKeyByName_prv(keyn, delPhase(strHead(tname,'_')), ky) !--- "ky" and "tnam" without phase
1140	ELSE
1141	IF(.NOT.ALLOCATED(tracers)) RETURN
1142	val = getKeyByName_prv(keyn, tname, tracers(:)%keys); IF(val /= '') RETURN !--- "tracers" and "tnam"
1143	IF(.NOT.ALLOCATED(isotopes)) RETURN
1144	IF(SIZE(isotopes) == 0) RETURN
1145	DO is = 1, SIZE(isotopes); IF(strIdx(isotopes(is)%keys(:)%name, delPhase(strHead(tname,'_'))) /= 0) EXIT; END DO
1146	IF(is /= 0) val = getKeyByName_prv(keyn, tname, isotopes(is)%keys(:)) !--- "isotopes" and "tnam" without phase
1147	END IF
1148
1149	CONTAINS
1150
1151	FUNCTION getKeyByName_prv(keyn, tname, ky) RESULT(val)
1152	CHARACTER(LEN=maxlen) :: val
1153	CHARACTER(LEN=*), INTENT(IN) :: keyn
1154	CHARACTER(LEN=*), INTENT(IN) :: tname
1155	TYPE(keys_type), INTENT(IN) :: ky(:)
1156	INTEGER :: itr, iky
1157	val = ''; iky = 0
1158	itr = strIdx(ky(:)%name, tname); IF(itr==0) RETURN !--- Get the index of the wanted tracer
1159	IF(itr /= 0) iky = strIdx(ky(itr)%key(:), keyn); IF(iky==0) RETURN !--- Wanted key index
1160	val = ky(itr)%val(iky)
1161	END FUNCTION getKeyByName_prv
1162
1163	END FUNCTION getKeyByName_s1
1164	!==============================================================================================================================
1165	LOGICAL FUNCTION getKeyByName_sm(keyn, val, tnam, ky) RESULT(lerr)
1166	CHARACTER(LEN=*), INTENT(IN) :: keyn
1167	CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
1168	CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tnam(:)
1169	TYPE(keys_type), TARGET, OPTIONAL, INTENT(IN) :: ky(:)
1170	CHARACTER(LEN=maxlen), POINTER :: n(:)
1171	INTEGER :: iq
1172	n => tracers(:)%keys%name; IF(PRESENT(tnam)) n => tnam(:)
1173	ALLOCATE(val(SIZE(n)))
1174	IF( PRESENT(ky)) lerr = ANY([(getKeyByName_s1(keyn, val(iq), n(iq), ky), iq=1, SIZE(n))])
1175	IF(.NOT.PRESENT(ky)) lerr = ANY([(getKeyByName_s1(keyn, val(iq), n(iq)), iq=1, SIZE(n))])
1176	END FUNCTION getKeyByName_sm
1177	!==============================================================================================================================
1178	LOGICAL FUNCTION getKeyByName_i1(keyn, val, tnam, ky) RESULT(lerr)
1179	CHARACTER(LEN=*), INTENT(IN) :: keyn
1180	INTEGER, INTENT(OUT) :: val
1181	CHARACTER(LEN=*), INTENT(IN) :: tnam
1182	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1183	CHARACTER(LEN=maxlen) :: sval
1184	INTEGER :: ierr
1185	IF( PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam, ky)
1186	IF(.NOT.PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam)
1187	IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tnam)//'" is missing', modname, lerr), lerr)) RETURN
1188	READ(sval, *, IOSTAT=ierr) val
1189	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tnam)//'" is not an integer', modname, lerr), lerr)) RETURN
1190	END FUNCTION getKeyByName_i1
1191	!==============================================================================================================================
1192	LOGICAL FUNCTION getKeyByName_im(keyn, val, tnam, ky) RESULT(lerr)
1193	CHARACTER(LEN=*), INTENT(IN) :: keyn
1194	INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:)
1195	CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tnam(:)
1196	TYPE(keys_type), TARGET, OPTIONAL, INTENT(IN) :: ky(:)
1197	CHARACTER(LEN=maxlen), POINTER :: n(:)
1198	INTEGER :: iq
1199	n => tracers(:)%name; IF(PRESENT(tnam)) n => tnam(:)
1200	ALLOCATE(val(SIZE(n)))
1201	IF( PRESENT(ky)) lerr = ANY([(getKeyByName_i1(keyn, val(iq), n(iq), ky), iq=1, SIZE(n))])
1202	IF(.NOT.PRESENT(ky)) lerr = ANY([(getKeyByName_i1(keyn, val(iq), n(iq)), iq=1, SIZE(n))])
1203	END FUNCTION getKeyByName_im
1204	!==============================================================================================================================
1205	LOGICAL FUNCTION getKeyByName_r1(keyn, val, tnam, ky) RESULT(lerr)
1206	CHARACTER(LEN=*), INTENT(IN) :: keyn
1207	REAL, INTENT(OUT) :: val
1208	CHARACTER(LEN=*), INTENT(IN) :: tnam
1209	TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:)
1210	CHARACTER(LEN=maxlen) :: sval
1211	INTEGER :: ierr
1212	IF( PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam, ky)
1213	IF(.NOT.PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam)
1214	IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tnam)//'" is missing', modname, lerr), lerr)) RETURN
1215	READ(sval, *, IOSTAT=ierr) val
1216	IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tnam)//'" is not a real', modname, lerr), lerr)) RETURN
1217	END FUNCTION getKeyByName_r1
1218	!==============================================================================================================================
1219	LOGICAL FUNCTION getKeyByName_rm(keyn, val, tnam, ky) RESULT(lerr)
1220	CHARACTER(LEN=*), INTENT(IN) :: keyn
1221	REAL, ALLOCATABLE, INTENT(OUT) :: val(:)
1222	CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tnam(:)
1223	TYPE(keys_type), TARGET, OPTIONAL, INTENT(IN) :: ky(:)
1224	CHARACTER(LEN=maxlen), POINTER :: n(:)
1225	INTEGER :: iq
1226	n => tracers(:)%name; IF(PRESENT(tnam)) n => tnam(:)
1227	ALLOCATE(val(SIZE(n)))
1228	IF( PRESENT(ky)) lerr = ANY([(getKeyByName_r1(keyn, val(iq), n(iq), ky), iq=1, SIZE(n))])
1229	IF(.NOT.PRESENT(ky)) lerr = ANY([(getKeyByName_r1(keyn, val(iq), n(iq)), iq=1, SIZE(n))])
1230	END FUNCTION getKeyByName_rm
1231	!==============================================================================================================================
1232
1233
1234	!==============================================================================================================================
1235	!=== REMOVE, IF ANY, OR ADD THE PHASE SUFFIX OF THE TRACER NAMED "s" ==========================================================
1236	!==============================================================================================================================
1237	ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION delPhase(s) RESULT(out)
1238	CHARACTER(LEN=*), INTENT(IN) :: s
1239	INTEGER :: l, i, ix
1240	out = s
1241	IF(s == '') RETURN !--- Empty string: nothing to do
1242	!--- Index of found phase in "known_phases"
1243	ix = MAXLOC( [(i, i=1,nphases)], MASK=[( INDEX(s, phases_sep//known_phases(i:i))/=0, i=1, nphases)], DIM=1 )
1244	IF(ix == 0) RETURN !--- No phase pattern found
1245	i = INDEX(s, phases_sep//known_phases(ix:ix)) !--- Index of <sep><pha> pattern in "str"
1246	l = LEN_TRIM(s)
1247	IF(i == l-1) THEN !--- <var><sep><pha> => return <var>
1248	out = s(1:l-2)
1249	ELSE IF(s(i+2:i+2) == '_') THEN !--- <var><sep><pha>_<tag> => return <var>_<tag>
1250	out = s(1:i-1)//s(i+2:l)
1251	END IF
1252	END FUNCTION delPhase
1253	!------------------------------------------------------------------------------------------------------------------------------
1254	CHARACTER(LEN=maxlen) FUNCTION addPhase_1(s,pha) RESULT(out)
1255	CHARACTER(LEN=*), INTENT(IN) :: s
1256	CHARACTER(LEN=1), INTENT(IN) :: pha
1257	INTEGER :: l, i
1258	out = s
1259	IF(s == '') RETURN !--- Empty string: nothing to do
1260	i = INDEX(s, '_') !--- /=0 for <var>_<tag> tracers names
1261	l = LEN_TRIM(s)
1262	IF(i == 0) out = TRIM(s)//phases_sep//pha !--- <var> => return <var><sep><pha>
1263	IF(i /= 0) out = s(1:i-1)//phases_sep//pha//'_'//s(i+1:l) !--- <var>_<tag> => return <var><sep><pha>_<tag>
1264	END FUNCTION addPhase_1
1265	!------------------------------------------------------------------------------------------------------------------------------
1266	FUNCTION addPhase_m(s,pha) RESULT(out)
1267	CHARACTER(LEN=*), INTENT(IN) :: s(:)
1268	CHARACTER(LEN=1), INTENT(IN) :: pha
1269	CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:)
1270	INTEGER :: k
1271	out = [( addPhase_1(s(k), pha), k=1, SIZE(s) )]
1272	END FUNCTION addPhase_m
1273	!------------------------------------------------------------------------------------------------------------------------------
1274
1275
1276	!==============================================================================================================================
1277	!=== GET THE NAME(S) OF THE ANCESTOR(S) OF TRACER(S) "tname" AT GENERATION "igen" IN THE TRACERS DESCRIPTORS LIST "tr" =======
1278	!==============================================================================================================================
1279	CHARACTER(LEN=maxlen) FUNCTION ancestor_1(t, tname, igen) RESULT(out)
1280	TYPE(trac_type), INTENT(IN) :: t(:)
1281	CHARACTER(LEN=*), INTENT(IN) :: tname
1282	INTEGER, OPTIONAL, INTENT(IN) :: igen
1283	INTEGER :: ig, ix
1284	ig = 1; IF(PRESENT(igen)) ig = igen
1285	ix = idxAncestor_1(t, tname, ig)
1286	out = ''; IF(ix /= 0) out = t(ix)%name
1287	END FUNCTION ancestor_1
1288	!------------------------------------------------------------------------------------------------------------------------------
1289	FUNCTION ancestor_m(t, tname, igen) RESULT(out)
1290	CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:)
1291	TYPE(trac_type), INTENT(IN) :: t(:)
1292	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: tname(:)
1293	INTEGER, OPTIONAL, INTENT(IN) :: igen
1294	INTEGER, ALLOCATABLE :: ix(:)
1295	INTEGER :: ig
1296	ig = 1; IF(PRESENT(igen)) ig = igen
1297	IF( PRESENT(tname)) ix = idxAncestor_m(t, tname, ig)
1298	IF(.NOT.PRESENT(tname)) ix = idxAncestor_m(t, t(:)%name, ig)
1299	ALLOCATE(out(SIZE(ix))); out(:) = ''
1300	WHERE(ix /= 0) out = t(ix)%name
1301	END FUNCTION ancestor_m
1302	!==============================================================================================================================
1303
1304
1305	!==============================================================================================================================
1306	!=== GET THE INDEX(ES) OF THE ANCESTOR(S) OF TRACER(S) "tname" AT GENERATION "igen" IN THE TRACERS DESCRIPTORS LIST "tr" =====
1307	!==============================================================================================================================
1308	INTEGER FUNCTION idxAncestor_1(t, tname, igen) RESULT(out)
1309	! Return the name of the generation "igen" ancestor of "tname"
1310	TYPE(trac_type), INTENT(IN) :: t(:)
1311	CHARACTER(LEN=*), INTENT(IN) :: tname
1312	INTEGER, OPTIONAL, INTENT(IN) :: igen
1313	INTEGER :: ig
1314	ig = 1; IF(PRESENT(igen)) ig = igen
1315	out = strIdx(t(:)%name, tname)
1316	IF(out == 0) RETURN
1317	IF(t(out)%iGeneration <= ig) RETURN
1318	DO WHILE(t(out)%iGeneration > ig); out = strIdx(t(:)%name, t(out)%parent); END DO
1319	END FUNCTION idxAncestor_1
1320	!------------------------------------------------------------------------------------------------------------------------------
1321	FUNCTION idxAncestor_m(t, tname, igen) RESULT(out)
1322	INTEGER, ALLOCATABLE :: out(:)
1323	TYPE(trac_type), INTENT(IN) :: t(:)
1324	CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: tname(:)
1325	INTEGER, OPTIONAL, INTENT(IN) :: igen
1326	INTEGER :: ig, ix
1327	ig = 1; IF(PRESENT(igen)) ig = igen
1328	IF( PRESENT(tname)) out = [(idxAncestor_1(t, tname(ix), ig), ix=1, SIZE(tname))]
1329	IF(.NOT.PRESENT(tname)) out = [(idxAncestor_1(t, t(ix)%name, ig), ix=1, SIZE(t))]
1330	END FUNCTION idxAncestor_m
1331	!==============================================================================================================================
1332
1333
1334	END MODULE readTracFiles_mod

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

Download in other formats:

Original Format