source: LMDZ6/branches/LMDZ_cdrag_LSCE/libf/misc/readTracFiles_mod.f90 @ 5158

Last change on this file since 5158 was 4669, checked in by Laurent Fairhead, 16 months ago

Merged with trunk revision 4586 corresponding to june 2023 testing

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