source: LMDZ6/trunk/libf/misc/readTracFiles_mod.f90 @ 4058

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

First commit for new tracers.

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