Context Navigation

readTracFiles_mod.f90 @ 4075

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

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

Download in other formats:

Original Format