source: LMDZ6/branches/contrails/libf/misc/readTracFiles_mod.f90 @ 5631

Last change on this file since 5631 was 5623, checked in by aborella, 3 months ago

Small bug corrections + temporary patch for children tracers in ICO (back to full parents tracers) + now truly no aviation data needed to run

File size: 175.6 KB
RevLine 
[4046]1MODULE readTracFiles_mod
2
[4987]3  USE strings_mod,    ONLY: msg, find, get_in, dispTable, strHead,  strReduce,  strFind, strStack, strIdx, &
[5001]4             removeComment, cat, fmsg, maxlen, checkList, strParse, strReplace, strTail, strCount, reduceExpr, &
5             int2str, str2int, real2str, str2real, bool2str, str2bool
[4046]6
7  IMPLICIT NONE
8
9  PRIVATE
10
[4325]11  PUBLIC :: maxlen                                              !--- PARAMETER FOR CASUAL STRING LENGTH
[5190]12  PUBLIC :: trac_type, tracers, setGeneration, indexUpdate      !--- TRACERS  DESCRIPTION DATABASE + ASSOCIATED TOOLS
[4325]13  PUBLIC :: testTracersFiles, readTracersFiles                  !--- TRACERS FILES READING ROUTINES
[4987]14  PUBLIC :: getKeysDBase, setKeysDBase                          !--- TOOLS TO GET/SET THE DATABASE (tracers & isotopes)
15  PUBLIC :: addTracer, delTracer                                !--- ADD/REMOVE A TRACER FROM
[5190]16  PUBLIC :: addKey,    delKey,    getKey,    keys_type          !--- TOOLS TO SET/DEL/GET KEYS FROM/TO  tracers & isotopes
[4987]17  PUBLIC :: addPhase,  delPhase,  getPhase,  getiPhase,  &      !--- FUNCTIONS RELATED TO THE PHASES
18   nphases, old_phases, phases_sep, known_phases, phases_names  !--- + ASSOCIATED VARIABLES
[4046]19
[4325]20  PUBLIC :: oldH2OIso, newH2OIso, old2newH2O, new2oldH2O        !--- H2O ISOTOPES BACKWARD COMPATIBILITY (OLD traceur.def)
21  PUBLIC :: oldHNO3,   newHNO3                                  !--- HNO3 REPRO   BACKWARD COMPATIBILITY (OLD start.nc)
[4120]22
[5001]23  PUBLIC :: tran0                                               !--- TRANSPORTING FLUID (USUALLY air)
[4301]24
25  !=== FOR ISOTOPES: GENERAL
[5001]26  PUBLIC :: isot_type, processIsotopes, isoSelect, ixIso, nbIso !--- PROCESS [AND READ] & SELECT ISOTOPES + CLASS IDX & NUMBER
[4301]27
[4325]28  !=== FOR ISOTOPES: H2O FAMILY ONLY
29  PUBLIC :: iH2O
30
31  !=== FOR ISOTOPES: DEPENDING ON THE SELECTED ISOTOPES CLASS
32  PUBLIC :: isotope, isoKeys                                    !--- SELECTED ISOTOPES DATABASE + ASSOCIATED KEYS
33  PUBLIC :: isoName, isoZone, isoPhas                           !--- ISOTOPES AND TAGGING ZONES NAMES AND PHASES
34  PUBLIC :: niso,    nzone,   nphas,   ntiso                    !---  " " NUMBERS + ISOTOPES AND TAGGING TRACERS NUMBERS
35  PUBLIC :: itZonIso                                            !--- Idx IN isoName(1:niso) = f(tagging idx, isotope idx)
36  PUBLIC :: iqIsoPha                                            !--- Idx IN qx(1:nqtot)     = f(isotope idx,   phase idx)
[5190]37  PUBLIC :: iqWIsoPha                                           !--- Idx IN qx(1:nqtot)     = f(isotope idx,   phase idx) but with normal water first
[4325]38  PUBLIC :: isoCheck                                            !--- FLAG TO RUN ISOTOPES CHECKING ROUTINES
39
[4193]40  PUBLIC :: maxTableWidth
[4046]41!------------------------------------------------------------------------------------------------------------------------------
[4987]42  TYPE :: keys_type                                             !=== TYPE FOR A SET OF KEYS ASSOCIATED TO AN ELEMENT
[5190]43    CHARACTER(LEN=maxlen)              :: name                  !--- Tracer name
[4987]44    CHARACTER(LEN=maxlen), ALLOCATABLE :: key(:)                !--- Keys string list
45    CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:)                !--- Corresponding values string list
[4325]46  END TYPE keys_type
47!------------------------------------------------------------------------------------------------------------------------------
[5190]48  TYPE :: trac_type                                             !=== TYPE FOR A SINGLE TRACER NAMED "name"
49    CHARACTER(LEN=maxlen) :: name        = ''                   !--- Name of the tracer
50    TYPE(keys_type)       :: keys                               !--- <key>=<val> pairs vector
51    CHARACTER(LEN=maxlen) :: gen0Name    = ''                   !--- First generation ancestor name
52    CHARACTER(LEN=maxlen) :: parent      = ''                   !--- Parent name
53    CHARACTER(LEN=maxlen) :: longName    = ''                   !--- Long name (with advection scheme suffix)
54    CHARACTER(LEN=maxlen) :: type        = 'tracer'             !--- Type  (so far: 'tracer' / 'tag')
55    CHARACTER(LEN=maxlen) :: phase       = 'g'                  !--- Phase ('g'as / 'l'iquid / 's'olid)
56    CHARACTER(LEN=maxlen) :: component   = ''                   !--- Coma-separated list of components (Ex: lmdz,inca)
57    INTEGER               :: iGeneration = -1                   !--- Generation number (>=0)
58    INTEGER               :: iqParent    = 0                    !--- Parent index
59    INTEGER,  ALLOCATABLE :: iqDescen(:)                        !--- Descendants index (in growing generation order)
60    INTEGER               :: nqDescen    = 0                    !--- Number of descendants (all generations)
61    INTEGER               :: nqChildren  = 0                    !--- Number of children  (first generation)
62    INTEGER               :: iadv        = 10                   !--- Advection scheme used
63    LOGICAL               :: isInPhysics = .TRUE.               !--- "true" tracers: in tr_seri. COUNT(isInPhysics)=nqtottr
[5618]64    INTEGER               :: iso_iGroup  = 0                    !--- Isotopes group index in isotopes(:)
[5190]65    INTEGER               :: iso_iName   = 0                    !--- Isotope  name  index in isotopes(iso_iGroup)%trac(:)
66    INTEGER               :: iso_iZone   = 0                    !--- Isotope  zone  index in isotopes(iso_iGroup)%zone(:)
67    INTEGER               :: iso_iPhase  = 0                    !--- Isotope  phase index in isotopes(iso_iGroup)%phase
68  END TYPE trac_type
69!------------------------------------------------------------------------------------------------------------------------------
70  TYPE :: isot_type                                             !=== TYPE FOR AN ISOTOPES FAMILY DESCENDING ON TRACER "parent"
71    CHARACTER(LEN=maxlen)              :: parent                !--- Isotopes family name (parent tracer name ; ex: H2O)
[4987]72    TYPE(keys_type),       ALLOCATABLE :: keys(:)               !--- Isotopes keys/values pairs list     (length: niso)
73    LOGICAL                            :: check=.FALSE.         !--- Flag for checking routines triggering
74    CHARACTER(LEN=maxlen), ALLOCATABLE :: trac(:)               !--- Isotopes + tagging tracers list     (length: ntiso)
75    CHARACTER(LEN=maxlen), ALLOCATABLE :: zone(:)               !--- Geographic tagging zones names list (length: nzone)
76    CHARACTER(LEN=maxlen)              :: phase = 'g'           !--- Phases list: [g][l][s]              (length: nphas)
77    INTEGER                            :: niso  = 0             !--- Number of isotopes, excluding tagging tracers
78    INTEGER                            :: ntiso = 0             !--- Number of isotopes, including tagging tracers
79    INTEGER                            :: nzone = 0             !--- Number of geographic tagging zones
80    INTEGER                            :: nphas = 0             !--- Number of phases
[5001]81    INTEGER,               ALLOCATABLE :: iqIsoPha(:,:)         !--- Idx in "tracers(1:nqtot)" = f(name(1:ntiso),phas)
[4987]82                                                                !---        (former name: "iqiso"
[5001]83    INTEGER,               ALLOCATABLE :: iqWIsoPha(:,:)        !--- Idx in "tracers(1:nqtot)" = f([H2O,name(1:ntiso)],phas)
[4987]84    INTEGER,               ALLOCATABLE :: itZonIso(:,:)         !--- Idx in "trac(1:ntiso)" = f(zone, name(1:niso))
85  END TYPE isot_type                                            !---        (former name: "index_trac")
[4325]86!------------------------------------------------------------------------------------------------------------------------------
87  TYPE :: dataBase_type                                         !=== TYPE FOR TRACERS SECTION
[4987]88    CHARACTER(LEN=maxlen) :: name                               !--- Section name
[5190]89    TYPE(trac_type), ALLOCATABLE :: trac(:)                     !--- Tracers descriptors
[4046]90  END TYPE dataBase_type
91!------------------------------------------------------------------------------------------------------------------------------
92  INTERFACE getKey
[5001]93    MODULE PROCEDURE &
94       getKeyByIndex_s111, getKeyByIndex_sm11, getKeyByIndex_s1m1, getKeyByIndex_smm1, getKeyByIndex_s1mm, getKeyByIndex_smmm, &
95       getKeyByIndex_i111, getKeyByIndex_im11, getKeyByIndex_i1m1, getKeyByIndex_imm1, getKeyByIndex_i1mm, getKeyByIndex_immm, &
96       getKeyByIndex_r111, getKeyByIndex_rm11, getKeyByIndex_r1m1, getKeyByIndex_rmm1, getKeyByIndex_r1mm, getKeyByIndex_rmmm, &
97       getKeyByIndex_l111, getKeyByIndex_lm11, getKeyByIndex_l1m1, getKeyByIndex_lmm1, getKeyByIndex_l1mm, getKeyByIndex_lmmm, &
98        getKeyByName_s111,  getKeyByName_sm11,  getKeyByName_s1m1,  getKeyByName_smm1,  getKeyByName_s1mm,  getKeyByName_smmm, &
99        getKeyByName_i111,  getKeyByName_im11,  getKeyByName_i1m1,  getKeyByName_imm1,  getKeyByName_i1mm,  getKeyByName_immm, &
100        getKeyByName_r111,  getKeyByName_rm11,  getKeyByName_r1m1,  getKeyByName_rmm1,  getKeyByName_r1mm,  getKeyByName_rmmm, &
101        getKeyByName_l111,  getKeyByName_lm11,  getKeyByName_l1m1,  getKeyByName_lmm1,  getKeyByName_l1mm,  getKeyByName_lmmm
[4046]102  END INTERFACE getKey
103!------------------------------------------------------------------------------------------------------------------------------
[4987]104  INTERFACE addKey
105    MODULE PROCEDURE addKey_s11, addKey_s1m, addKey_smm, addKey_i11, addKey_i1m, addKey_imm, &
106                     addKey_r11, addKey_r1m, addKey_rmm, addKey_l11, addKey_l1m, addKey_lmm
107  END INTERFACE addKey
108!------------------------------------------------------------------------------------------------------------------------------
[5001]109  INTERFACE     isoSelect; MODULE PROCEDURE  isoSelectByIndex,  isoSelectByName; END INTERFACE isoSelect
110  INTERFACE    old2newH2O; MODULE PROCEDURE  old2newH2O_1,  old2newH2O_m;        END INTERFACE old2newH2O
111  INTERFACE    new2oldH2O; MODULE PROCEDURE  new2oldH2O_1,  new2oldH2O_m;        END INTERFACE new2oldH2O
112  INTERFACE     addTracer; MODULE PROCEDURE   addTracer_1, addTracer_1def;       END INTERFACE addTracer
113  INTERFACE     delTracer; MODULE PROCEDURE   delTracer_1, delTracer_1def;       END INTERFACE delTracer
114  INTERFACE      addPhase; MODULE PROCEDURE   addPhase_s1,  addPhase_sm,  addPhase_i1,  addPhase_im; END INTERFACE addPhase
115  INTERFACE tracersSubset; MODULE PROCEDURE trSubset_Indx,     trSubset_Name,     trSubset_gen0Name; END INTERFACE tracersSubset
[4046]116!------------------------------------------------------------------------------------------------------------------------------
117
118  !=== MAIN DATABASE: files sections descriptors
119  TYPE(dataBase_type), SAVE, ALLOCATABLE, TARGET :: dBase(:)
120
121  !--- SOME PARAMETERS THAT ARE NOT LIKELY TO CHANGE OFTEN
[4301]122  CHARACTER(LEN=maxlen), SAVE      :: tran0        = 'air'      !--- Default transporting fluid
[5623]123  CHARACTER(LEN=maxlen), PARAMETER :: old_phases   = 'vlibfcapqt'     !--- Old phases for water (no separator)
124  CHARACTER(LEN=maxlen), PARAMETER :: known_phases = 'glsbfcapqt'     !--- Known phases initials
[4301]125  INTEGER, PARAMETER :: nphases = LEN_TRIM(known_phases)        !--- Number of phases
126  CHARACTER(LEN=maxlen), SAVE      :: phases_names(nphases) &   !--- Known phases names
[5623]127                                = ['gaseous  ', 'liquid   ', 'solid    ','blownSnow', 'fraccld  ', 'cldvap   ', 'avifrac  ', 'pavifra  ', 'qvapavi  ', 'ticeavi  ']
[4987]128  CHARACTER(LEN=1),      SAVE :: phases_sep  =  '_'             !--- Phase separator
[4325]129  CHARACTER(LEN=maxlen), SAVE :: isoFile = 'isotopes_params.def'!--- Name of the isotopes parameters file
[4046]130
[4301]131  !--- CORRESPONDANCE BETWEEN OLD AND NEW WATER NAMES
[4400]132  CHARACTER(LEN=maxlen), SAVE :: oldH2OIso(5) = ['eau',   'HDO',   'O18',   'O17',   'HTO'  ]
133  CHARACTER(LEN=maxlen), SAVE :: newH2OIso(5) = ['H216O', 'HDO  ', 'H218O', 'H217O', 'HTO  ']
[4120]134
[4987]135  !--- CORRESPONDANCE BETWEEN OLD AND NEW HNO3 RELATED SPECIES NAMES (FOR REPROBUS)
[4301]136  CHARACTER(LEN=maxlen), SAVE ::   oldHNO3(2) = ['HNO3_g ', 'HNO3   ']
137  CHARACTER(LEN=maxlen), SAVE ::   newHNO3(2) = ['HNO3   ', 'HNO3tot']
138
[4325]139  !=== TRACERS AND ISOTOPES DESCRIPTORS, USED BY getKey
[5190]140  TYPE(trac_type), ALLOCATABLE, TARGET, SAVE ::  tracers(:)
[4046]141  TYPE(isot_type), ALLOCATABLE, TARGET, SAVE :: isotopes(:)
142
[4325]143  !=== ALIASES OF VARIABLES FROM SELECTED ISOTOPES FAMILY EMBEDDED IN "isotope" (isotopes(ixIso))
144  TYPE(isot_type),         SAVE, POINTER :: isotope             !--- CURRENTLY SELECTED ISOTOPES FAMILY DESCRIPTOR
[4987]145  INTEGER,                 SAVE          :: ixIso, iH2O=0       !--- Index of the selected isotopes family and H2O family
[4325]146  INTEGER,                 SAVE          :: nbIso               !--- Number of isotopes classes
147  LOGICAL,                 SAVE          :: isoCheck            !--- Flag to trigger the checking routines
148  TYPE(keys_type),         SAVE, POINTER :: isoKeys(:)          !--- ONE SET OF KEYS FOR EACH ISOTOPE (LISTED IN isoName)
149  CHARACTER(LEN=maxlen),   SAVE, POINTER :: isoName(:),   &     !--- ISOTOPES NAMES FOR THE CURRENTLY SELECTED FAMILY
150                                            isoZone(:),   &     !--- TAGGING ZONES  FOR THE CURRENTLY SELECTED FAMILY
151                                            isoPhas             !--- USED PHASES    FOR THE CURRENTLY SELECTED FAMILY
152  INTEGER,                 SAVE          ::  niso, nzone, &     !--- NUMBER OF ISOTOPES, TAGGING ZONES AND PHASES
153                                            nphas, ntiso        !--- NUMBER OF PHASES AND ISOTOPES + ISOTOPIC TAGGING TRACERS
154  INTEGER,                 SAVE, POINTER ::itZonIso(:,:), &     !--- INDEX IN "isoTrac" AS f(tagging zone idx,  isotope idx)
[5001]155                                           iqIsoPha(:,:), &     !--- INDEX IN "qx" AS f(isotopic tracer idx, phase idx)
156                                           iqWIsoPha(:,:)       !--- INDEX IN "qx" AS f(H2O + isotopic tracer idx, phase idx)
[4325]157
[4987]158  !=== PARAMETERS FOR DEFAULT BEHAVIOUR
159  LOGICAL, PARAMETER :: lTracsMerge = .FALSE.                   !--- Merge/stack tracers lists
160  LOGICAL, PARAMETER :: lSortByGen  = .TRUE.                    !--- Sort by growing generation
161
[4325]162  INTEGER,    PARAMETER :: maxTableWidth = 192                  !--- Maximum width of a table displayed with "dispTable"
[4046]163  CHARACTER(LEN=maxlen) :: modname
164
165CONTAINS
166
167!==============================================================================================================================
168!==============================================================================================================================
169!=== READ ONE OR SEVERAL TRACER FILES AND FILL A "tr" TRACERS DESCRIPTOR DERIVED TYPE.
[4301]170!=== THE RETURNED VALUE fType DEPENDS ON WHAT IS FOUND:
[4046]171!===  0: NO ADEQUATE FILE FOUND ; DEFAULT VALUES MUST BE USED
172!===  1: AN "OLD STYLE" TRACERS FILE "traceur.def":
173!===    First line: <nb tracers>     Other lines: <hadv> <vadv> <tracer name> [<parent name>]
174!===  2: A  "NEW STYLE" TRACERS FILE  "tracer.def" WITH SEVERAL SECTIONS.
175!===  3: SEVERAL  "  "  TRACERS FILES "tracer_<component>.def" WITH A SINGLE SECTION IN EACH.
176!=== REMARKS:
177!===  * EACH SECTION BEGINS WITH A "&<section name> LINE
178!===  * DEFAULT VALUES FOR ALL THE SECTIONS OF THE FILE ARE DEFINED IN THE SPECIAL SECTION "&default"
179!===  * EACH SECTION LINE HAS THE STRUCTURE:  <name(s)>  <key1>=<value1> <key2>=<value2> ...
180!===  * SO FAR, THE DEFINED KEYS ARE: parent, phases, hadv, vadv, type
181!===  * <name> AND <parent> CAN BE LISTS OF COMA-SEPARATED TRACERS ; THE ROUTINE EXPAND THESE FACTORIZATIONS.
182!=== FUNCTION RETURN VALUE "lerr" IS FALSE IN CASE SOMETHING WENT WRONG.
183!=== ABOUT THE KEYS:
184!     * The "keys" component (of type keys_type) is in principle enough to store everything we could need.
185!     But some variables are stored as direct-access keys to make the code more readable and because they are used often.
[5618]186!     * Most of the direct-access keys are set in this module, but some are not (longName, iadv and isInPhysicsfor now).
[4046]187!     * Some of the direct-access keys must be updated (using the routine "setDirectKeys") is a subset of "tracers(:)"
[4063]188!     is extracted: the indexes are no longer valid for a subset (examples: iqParent, iqDescen).
[4046]189!     * If you need to convert a %key/%val pair into a direct-access key, add the corresponding line in "setDirectKeys".
190!==============================================================================================================================
[5001]191LOGICAL FUNCTION readTracersFiles(type_trac, tracs, lRepr) RESULT(lerr)
[4046]192!------------------------------------------------------------------------------------------------------------------------------
[5001]193  CHARACTER(LEN=*),                               INTENT(IN)  :: type_trac     !--- List of components used
[5190]194  TYPE(trac_type), ALLOCATABLE, TARGET, OPTIONAL, INTENT(OUT) :: tracs(:)      !--- Tracers descriptor for external storage
[5001]195  LOGICAL,                              OPTIONAL, INTENT(IN)  :: lRepr         !--- Activate the HNO3 exceptions for REPROBUS
[4120]196  CHARACTER(LEN=maxlen),  ALLOCATABLE :: s(:), sections(:), trac_files(:)
[5190]197  CHARACTER(LEN=maxlen) :: str, fname, tname, pname, cname
[4325]198  INTEGER               :: nsec, ierr, it, ntrac, ns, ip, ix, fType
[5001]199  INTEGER, ALLOCATABLE  :: iGen(:)
[4301]200  LOGICAL :: lRep
[4325]201  TYPE(keys_type), POINTER :: k
[4046]202!------------------------------------------------------------------------------------------------------------------------------
203  lerr = .FALSE.
204  modname = 'readTracersFiles'
205  IF(.NOT.ALLOCATED(dBase)) ALLOCATE(dBase(0))
[4363]206  lRep=.FALSE.; IF(PRESENT(lRepr)) lRep = lRepr
[4046]207
[4325]208  !--- Required sections + corresponding files names (new style single section case) for tests
[5001]209  lerr = testTracersFiles(modname, type_trac, fType, .FALSE., trac_files, sections); IF(lerr) RETURN
[4325]210  nsec = SIZE(sections)
[4046]211
212  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
[5001]213  SELECT CASE(fType)                         !--- Set name, component, parent, phase, iGeneration, gen0Name, type
[4046]214  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
[4301]215    CASE(1)                                                          !=== OLD FORMAT "traceur.def"
[4063]216    !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
217      !--- OPEN THE "traceur.def" FILE
[5001]218      OPEN(90, FILE="traceur.def", FORM='formatted', STATUS='old', POSITION='REWIND', IOSTAT=ierr)
[4046]219
[4063]220      !--- GET THE TRACERS NUMBER
221      READ(90,'(i3)',IOSTAT=ierr)ntrac                               !--- Number of lines/tracers
[5001]222      lerr = ierr/=0; IF(fmsg('Invalid format for "'//TRIM(fname)//'"', modname, lerr)) RETURN
[4046]223
[4063]224      !--- READ THE REMAINING LINES: <hadv> <vadv> <tracer> [<transporting fluid>]
[4325]225      ALLOCATE(tracers(ntrac))
[5001]226      DO it = 1, ntrac                                               !=== READ RAW DATA: loop on the line/tracer number
[4063]227        READ(90,'(a)',IOSTAT=ierr) str
[5001]228        lerr = ierr>0; IF(fmsg('Invalid format for "' //TRIM(fname)//'"', modname, lerr)) RETURN
229        lerr = ierr<0; IF(fmsg('Not enough lines in "'//TRIM(fname)//'"', modname, lerr)) RETURN
[4348]230        lerr = strParse(str, ' ', s, ns)
[4063]231        CALL msg('This file is for air tracers only',           modname, ns == 3 .AND. it == 1)
232        CALL msg('This files specifies the transporting fluid', modname, ns == 4 .AND. it == 1)
[5190]233        k => tracers(it)%keys
[4301]234
235        !=== NAME OF THE TRACER
236        tname = old2newH2O(s(3), ip)
237        ix = strIdx(oldHNO3, s(3))
238        IF(ix /= 0 .AND. lRep) tname = newHNO3(ix)                   !--- Exception for HNO3 (REPROBUS ONLY)
[5190]239        tracers(it)%name = tname                                     !--- Set the name of the tracer
240        CALL addKey('name', tname, k)                                !--- Set the name of the tracer
241        tracers(it)%keys%name = tname                                !--- Copy tracers names in keys components
[4301]242
243        !=== NAME OF THE COMPONENT
244        cname = type_trac                                            !--- Name of the model component
245        IF(ANY([(addPhase('H2O', ip), ip = 1, nphases)] == tname)) cname = 'lmdz'
[5190]246        tracers(it)%component = cname                                !--- Set component
247        CALL addKey('component', cname, k)                           !--- Set the name of the model component
[4301]248
249        !=== NAME OF THE PARENT
250        pname = tran0                                                !--- Default name: default transporting fluid (air)
251        IF(ns == 4) THEN
252          pname = old2newH2O(s(4))
253          ix = strIdx(oldHNO3, s(4))
254          IF(ix /= 0 .AND. lRep) pname = newHNO3(ix)                 !--- Exception for HNO3 (REPROBUS ONLY)
255        END IF
[5190]256        tracers(it)%parent = pname                                   !--- Set the parent name
257        CALL addKey('parent', pname, k)
[4301]258
259        !=== PHASE AND ADVECTION SCHEMES NUMBERS
[5190]260        tracers(it)%phase = known_phases(ip:ip)                      !--- Set the phase of the tracer (default: "g"azeous)
261        CALL addKey('phase', known_phases(ip:ip), k)                 !--- Set the phase of the tracer (default: "g"azeous)
[5001]262        CALL addKey('hadv', s(1),  k)                                !--- Set the horizontal advection schemes number
263        CALL addKey('vadv', s(2),  k)                                !--- Set the vertical   advection schemes number
[4063]264      END DO
265      CLOSE(90)
[5001]266      lerr = setGeneration(tracers); IF(lerr) RETURN                 !--- Set iGeneration and gen0Name
[5190]267      lerr = getKey('iGeneration', iGen, tracers(:)%keys)            !--- Generation number
268      WHERE(iGen == 2) tracers(:)%type = 'tag'                       !--- Set type:      'tracer' or 'tag'
[5005]269      DO it = 1, ntrac
[5190]270        CALL addKey('type', tracers(it)%type, tracers(it)%keys)      !--- Set the type of tracer
[5005]271      END DO
[5001]272      lerr = checkTracers(tracers, fname, fname); IF(lerr) RETURN    !--- Detect orphans and check phases
273      lerr = checkUnique (tracers, fname, fname); IF(lerr) RETURN    !--- Detect repeated tracers
274      CALL sortTracers   (tracers)                                   !--- Sort the tracers
[4063]275    !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
[5001]276    CASE(2); lerr=feedDBase(["tracer.def"], [type_trac], modname); IF(lerr) RETURN  !=== SINGLE   FILE, MULTIPLE SECTIONS
[4063]277    !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
[5001]278    CASE(3); lerr=feedDBase(  trac_files  ,  sections,   modname); IF(lerr) RETURN  !=== MULTIPLE FILES, SINGLE  SECTION
[4046]279  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
[4063]280  END SELECT
[4046]281  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
[4120]282  IF(ALL([2,3] /= fType)) RETURN
[5001]283  IF(nsec == 1) tracers = dBase(1)%trac
284  IF(nsec /= 1) THEN
285    CALL msg('Multiple sections are MERGED',    modname,      lTracsMerge)
286    CALL msg('Multiple sections are CUMULATED', modname, .NOT.lTracsMerge)
287    IF(     lTracsMerge) lerr = cumulTracers(dBase, tracers)
288    IF(.NOT.lTracsMerge) lerr = cumulTracers(dBase, tracers)
289    IF(lerr) RETURN
290  END IF
291  lerr = indexUpdate(tracers); IF(lerr) RETURN                       !--- Set iqParent, iqDescen, nqDescen, nqChildren
[5190]292  IF(PRESENT(tracs)) CALL MOVE_ALLOC(FROM=tracers, TO=tracs)
[4046]293END FUNCTION readTracersFiles
294!==============================================================================================================================
295
[4325]296
[4046]297!==============================================================================================================================
[4328]298LOGICAL FUNCTION testTracersFiles(modname, type_trac, fType, lDisp, tracf, sects) RESULT(lerr)
[4325]299  CHARACTER(LEN=*),                             INTENT(IN)  :: modname, type_trac
300  INTEGER,                                      INTENT(OUT) :: fType
[4389]301  LOGICAL,                            OPTIONAL, INTENT(IN)  :: lDisp
[4325]302  CHARACTER(LEN=maxlen), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: tracf(:), sects(:)
303  CHARACTER(LEN=maxlen), ALLOCATABLE :: trac_files(:), sections(:)
304  LOGICAL, ALLOCATABLE :: ll(:)
[4454]305  LOGICAL :: lD, lFound
[4325]306  INTEGER :: is, nsec
[4389]307  lD = .FALSE.; IF(PRESENT(lDisp)) lD = lDisp
308  lerr = .FALSE.
[4325]309
[4389]310  !--- PARSE "type_trac" LIST AND DETERMINE THE TRACERS FILES NAMES (FOR CASE 3: MULTIPLE FILES, SINGLE SECTION PER FILE)
311  !--- If type_trac is a scalar (case 1), "sections" and "trac_files" are not usable, but are meaningless for case 1 anyway.
[5001]312  lerr = strParse(type_trac, '|', sections, n=nsec); IF(lerr) RETURN !--- Parse "type_trac" list
[4325]313  IF(PRESENT(sects)) sects = sections
[4454]314  ALLOCATE(trac_files(nsec), ll(nsec))
315  DO is=1, nsec
316     trac_files(is) = 'tracer_'//TRIM(sections(is))//'.def'
317     INQUIRE(FILE=TRIM(trac_files(is)), EXIST=ll(is))
318  END DO
[4325]319  IF(PRESENT(tracf)) tracf = trac_files
320  fType = 0
[4454]321  INQUIRE(FILE='traceur.def', EXIST=lFound); IF(lFound)  fType = 1   !--- OLD STYLE FILE
322  INQUIRE(FILE='tracer.def',  EXIST=lFound); IF(lFound)  fType = 2   !--- NEW STYLE ; SINGLE  FILE, SEVERAL SECTIONS
323                                             IF(ALL(ll)) fType = 3   !--- NEW STYLE ; SEVERAL FILES, SINGLE SECTION USED
[4389]324  IF(.NOT.lD) RETURN                                                 !--- NO CHECKING/DISPLAY NEEDED: JUST GET type_trac,fType
[4325]325  IF(ANY(ll) .AND. fType/=3) THEN                                    !--- MISSING FILES
[5001]326    lerr = checkList(trac_files, .NOT.ll, 'Failed reading tracers description', 'files', 'missing'); IF(lerr) RETURN
[4325]327  END IF
328
329  !--- TELLS WHAT WAS IS ABOUT TO BE USED
330  CALL msg('Trying to read old-style tracers description file "traceur.def"',                      modname, fType==1)
331  CALL msg('Trying to read the new style multi-sections tracers description file "tracer.def"',    modname, fType==2)
332  CALL msg('Trying to read the new style single section tracers description files "tracer_*.def"', modname, fType==3)
333END FUNCTION testTracersFiles
334!==============================================================================================================================
335
336!==============================================================================================================================
[4120]337LOGICAL FUNCTION feedDBase(fnames, snames, modname) RESULT(lerr)
[4169]338! Purpose: Read the sections "snames(is)" (pipe-separated list) from each "fnames(is)"
[4046]339!   file and create the corresponding tracers set descriptors in the database "dBase":
[5190]340! * dBase(id)%name                : section name
341! * dBase(id)%trac(:)%name        : tracers names
342! * dBase(id)%trac(it)%keys%key(:): names  of keys associated to tracer dBase(id)%trac(it)%name
343! * dBase(id)%trac(it)%keys%val(:): values of keys associated to tracer dBase(id)%trac(it)%name
[4046]344!------------------------------------------------------------------------------------------------------------------------------
345  CHARACTER(LEN=*), INTENT(IN)  :: fnames(:)                         !--- Files names
[4169]346  CHARACTER(LEN=*), INTENT(IN)  :: snames(:)                         !--- Pipe-deparated list of sections (one list each file)
[4120]347  CHARACTER(LEN=*), INTENT(IN)  :: modname                           !--- Calling routine name
348  INTEGER,  ALLOCATABLE :: ndb(:)                                    !--- Number of sections for each file
[4046]349  INTEGER,  ALLOCATABLE :: ixf(:)                                    !--- File index for each section of the expanded list
[4120]350  CHARACTER(LEN=maxlen) :: fnm, snm
[4046]351  INTEGER               :: idb, i
352  LOGICAL :: ll
353!------------------------------------------------------------------------------------------------------------------------------
354  !=== READ THE REQUIRED SECTIONS
[4169]355  ll = strCount(snames, '|', ndb)                                    !--- Number of sections for each file
[4046]356  ALLOCATE(ixf(SUM(ndb)))
[5001]357  DO i=1, SIZE(fnames)                                               !--- Set name, keys
358    lerr = readSections(fnames(i), snames(i), 'default'); IF(lerr) RETURN
[4046]359    ixf(1+SUM(ndb(1:i-1)):SUM(ndb(1:i))) = i                         !--- File index for each section of the expanded list
360  END DO
361  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
362  DO idb=1,SIZE(dBase)                                               !--- LOOP ON THE LOADED SECTIONS
363  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
[4063]364    fnm = fnames(ixf(idb)); snm = dBase(idb)%name                    !--- FILE AND SECTION NAMES
[4120]365    lerr = ANY([(dispTraSection('RAW CONTENT OF SECTION "'//TRIM(snm)//'"', snm, modname), idb=1, SIZE(dBase))])
[5001]366    lerr = expandSection(dBase(idb)%trac, snm, fnm); IF(lerr) RETURN !--- EXPAND NAMES ;  SET parent, type, component
367    lerr = setGeneration(dBase(idb)%trac);           IF(lerr) RETURN !---                 SET iGeneration,  genOName
368    lerr = checkTracers (dBase(idb)%trac, snm, fnm); IF(lerr) RETURN !--- CHECK ORPHANS AND PHASES
369    lerr = checkUnique  (dBase(idb)%trac, snm, fnm); IF(lerr) RETURN !--- CHECK TRACERS UNIQUENESS
370    lerr = expandPhases (dBase(idb)%trac);           IF(lerr) RETURN !--- EXPAND PHASES ; set phase
371    CALL sortTracers    (dBase(idb)%trac)                            !--- SORT TRACERS
[4120]372    lerr = ANY([(dispTraSection('EXPANDED CONTENT OF SECTION "'//TRIM(snm)//'"', snm, modname), idb=1, SIZE(dBase))])
[4046]373  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
374  END DO
375  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
376END FUNCTION feedDBase
377!------------------------------------------------------------------------------------------------------------------------------
378
379!------------------------------------------------------------------------------------------------------------------------------
380LOGICAL FUNCTION readSections(fnam,snam,defName) RESULT(lerr)
381!------------------------------------------------------------------------------------------------------------------------------
382  CHARACTER(LEN=*),           INTENT(IN) :: fnam                     !--- File name
[4169]383  CHARACTER(LEN=*),           INTENT(IN) :: snam                     !--- Pipe-separated sections list
[4046]384  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: defName                  !--- Special section (default values) name
385!------------------------------------------------------------------------------------------------------------------------------
386  TYPE(dataBase_type),   ALLOCATABLE :: tdb(:)
387  CHARACTER(LEN=maxlen), ALLOCATABLE :: sec(:)
388  INTEGER,               ALLOCATABLE ::  ix(:)
[4363]389  INTEGER :: n0, idb, ndb
[4046]390  LOGICAL :: ll
391!------------------------------------------------------------------------------------------------------------------------------
392  n0 = SIZE(dBase) + 1                                               !--- Index for next entry in the database
393  CALL readSections_all()                                            !--- Read all the sections of file "fnam"
394  ndb= SIZE(dBase)                                                   !--- Current number of sections in the database
395  IF(PRESENT(defName)) THEN                                          !--- Add default values to all the tracers
[5190]396    DO idb=n0,ndb; CALL addDefault(dBase(idb)%trac, defName); END DO !--- and remove the virtual tracer "defName"
[4046]397  END IF
[4169]398  ll = strParse(snam, '|', keys = sec)                               !--- Requested sections names
[4046]399  ix = strIdx(dBase(:)%name, sec(:))                                 !--- Indexes of requested sections in database
[5001]400  lerr = checkList(sec, ix == 0, 'In file "'//TRIM(fnam)//'"','section(s)', 'missing'); IF(lerr) RETURN
[4046]401  tdb = dBase(:); dBase = [tdb(1:n0-1),tdb(PACK(ix, MASK=ix/=0))]    !--- Keep requested sections only
402
403CONTAINS
404
405!------------------------------------------------------------------------------------------------------------------------------
406SUBROUTINE readSections_all()
407!------------------------------------------------------------------------------------------------------------------------------
408  CHARACTER(LEN=maxlen), ALLOCATABLE ::  s(:), v(:)
[5190]409  TYPE(trac_type),       ALLOCATABLE :: tt(:)
410  TYPE(trac_type)       :: tmp
[4193]411  CHARACTER(LEN=1024)   :: str, str2
[4046]412  CHARACTER(LEN=maxlen) :: secn
413  INTEGER               :: ierr, n
414!------------------------------------------------------------------------------------------------------------------------------
415  IF(.NOT.ALLOCATED(dBase)) ALLOCATE(dBase(0))
[5001]416  OPEN(90, FILE=fnam, FORM='formatted', POSITION='REWIND', STATUS='old')
[4193]417  DO; str=''
418    DO
419      READ(90,'(a)', IOSTAT=ierr)str2                                !--- Read a full line
420      str=TRIM(str)//' '//TRIM(str2)                                 !--- Append "str" with the current line
421      n=LEN_TRIM(str); IF(n == 0) EXIT                               !--- Empty line (probably end of file)
422      IF(IACHAR(str(n:n))  /= 92) EXIT                               !--- No "\" continuing line symbol found => end of line
423      str = str(1:n-1)                                               !--- Remove the "\" continuing line symbol
424    END DO
425    str = ADJUSTL(str)                                               !--- Remove the front space
[4046]426    IF(ierr    /= 0 ) EXIT                                           !--- Finished: error or end of file
427    IF(str(1:1)=='#') CYCLE                                          !--- Skip comments lines
428    CALL removeComment(str)                                          !--- Skip comments at the end of a line
[5001]429    IF(LEN_TRIM(str) == 0) CYCLE                                     !--- Empty line (probably end of file)
[4046]430    IF(str     == '') CYCLE                                          !--- Skip empty line (probably at the end of the file)
431    IF(str(1:1)=='&') THEN                                           !=== SECTION HEADER LINE
432      ndb  = SIZE(dBase)                                             !--- Number of sections so far
433      secn = str(2:LEN_TRIM(str))//' '                               !--- Current section name
434      IF(ANY(dBase(:)%name == secn)) CYCLE                           !--- Already known section
435      IF(secn(1:7) == 'version')     CYCLE                           !--- Skip the "version" special section
436      ndb = ndb + 1                                                  !--- Extend database
437      ALLOCATE(tdb(ndb))
438      tdb(1:ndb-1)  = dBase
439      tdb(ndb)%name = secn
440      ALLOCATE(tdb(ndb)%trac(0))
441      CALL MOVE_ALLOC(FROM=tdb, TO=dBase)
442    ELSE                                                             !=== TRACER LINE
[4348]443      ll = strParse(str,' ', s, n, v)                                !--- Parse <key>=<val> pairs
[4046]444      tt = dBase(ndb)%trac(:)
[4987]445      v(1) = s(1); s(1) = 'name'                                     !--- Convert "name" into a regular key
[5190]446      tmp%name = v(1); tmp%keys = keys_type(v(1), s(:), v(:))        !--- Set %name and %keys
447      dBase(ndb)%trac = [tt(:), tmp]
448      DEALLOCATE(tt, tmp%keys%key, tmp%keys%val)
[4046]449    END IF
450  END DO
451  CLOSE(90)
452
453END SUBROUTINE readSections_all
454!------------------------------------------------------------------------------------------------------------------------------
455
456END FUNCTION readSections
457!==============================================================================================================================
458
459
460!==============================================================================================================================
[5190]461SUBROUTINE addDefault(t, defName)
[4046]462!------------------------------------------------------------------------------------------------------------------------------
463! Purpose: Add the keys from virtual tracer named "defName" (if any) and remove this virtual tracer.
464!------------------------------------------------------------------------------------------------------------------------------
[5190]465  TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:)
[4046]466  CHARACTER(LEN=*),                     INTENT(IN)    :: defName
467  INTEGER :: jd, it, k
[5190]468  TYPE(keys_type), POINTER :: ky
469  TYPE(trac_type), ALLOCATABLE :: tt(:)
470  jd = strIdx(t(:)%name, defName)
[4046]471  IF(jd == 0) RETURN
[5190]472  ky => t(jd)%keys
473  DO k = 1, SIZE(ky%key)                                             !--- Loop on the keys of the tracer named "defName"
474!   CALL addKey(ky%key(k), ky%val(k), t(:)%keys, .FALSE.)            !--- Add key to all the tracers (no overwriting)
475    DO it = 1, SIZE(t); CALL addKey(ky%key(k), ky%val(k), t(it)%keys, .FALSE.); END DO
[4046]476  END DO
477  tt = [t(1:jd-1),t(jd+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t)   !--- Remove the virtual tracer named "defName"
[5190]478END SUBROUTINE addDefault
[4046]479!==============================================================================================================================
480
481!==============================================================================================================================
[5190]482SUBROUTINE subDefault(t, defName, lSubLocal)
[4046]483!------------------------------------------------------------------------------------------------------------------------------
484! Purpose: Substitute the keys from virtual tracer named "defName" (if any) and remove this virtual tracer.
485!          Substitute the keys locally (for the current tracer) if the flag "lSubLocal" is .TRUE.
486!------------------------------------------------------------------------------------------------------------------------------
[5190]487  TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:)
[4046]488  CHARACTER(LEN=*),                     INTENT(IN)    :: defName
489  LOGICAL,                              INTENT(IN)    :: lSubLocal
490  INTEGER :: i0, it, ik
[5190]491  TYPE(keys_type), POINTER     :: k0, ky
492  TYPE(trac_type), ALLOCATABLE :: tt(:)
493  i0 = strIdx(t(:)%name, defName)
[4046]494  IF(i0 == 0) RETURN
[5190]495  k0 => t(i0)%keys
[4046]496  DO it = 1, SIZE(t); IF(it == i0) CYCLE                             !--- Loop on the tracers
[5190]497    ky => t(it)%keys
[4046]498
499    !--- Substitute in the values of <key>=<val> pairs the keys defined in the virtual tracer "defName"
[5190]500    DO ik = 1, SIZE(k0%key); CALL strReplace(ky%val, k0%key(ik), k0%val(ik), .TRUE.); END DO
[4046]501
502    IF(.NOT.lSubLocal) CYCLE
503    !--- Substitute in the values of <key>=<val> pairs the keys defined locally (in the current tracer)
[5190]504    DO ik = 1, SIZE(ky%key); CALL strReplace(ky%val, ky%key(ik), ky%val(ik), .TRUE.); END DO
[4046]505  END DO
506  tt = [t(1:i0-1),t(i0+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t)   !--- Remove the virtual tracer named "defName"
507
[5190]508END SUBROUTINE subDefault
[4046]509!==============================================================================================================================
510
511
512!==============================================================================================================================
513LOGICAL FUNCTION expandSection(tr, sname, fname) RESULT(lerr)
514!------------------------------------------------------------------------------------------------------------------------------
515! Purpose: Expand tracers and parents lists in the tracers descriptor "tra".
516! Note:  * The following keys are expanded, so are accessible explicitely using "%" operator: "parent" "type".
517!        * Default values are provided for these keys because they are necessary.
518!------------------------------------------------------------------------------------------------------------------------------
[5190]519  TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:)                 !--- Tracer derived type vector
[5001]520  CHARACTER(LEN=*),             INTENT(IN)    :: sname                 !--- Current section name
521  CHARACTER(LEN=*), OPTIONAL,   INTENT(IN)    :: fname                 !--- Tracers description file name
[5190]522  TYPE(trac_type),       ALLOCATABLE :: ttr(:)
[5001]523  CHARACTER(LEN=maxlen), ALLOCATABLE :: ta(:), pa(:), tname(:), parent(:), dType(:)
[4363]524  CHARACTER(LEN=maxlen) :: msg1, modname
525  INTEGER :: it, nt, iq, nq, itr, ntr, ipr, npr
[4046]526  LOGICAL :: ll
527  modname = 'expandSection'
528  lerr = .FALSE.
529  nt = SIZE(tr)
[5190]530  lerr = getKey('name',   tname,  tr(:)%keys);                 IF(lerr) RETURN
531  lerr = getKey('parent', parent, tr(:)%keys, def = tran0);    IF(lerr) RETURN
532  lerr = getKey('type',   dType,  tr(:)%keys, def = 'tracer'); IF(lerr) RETURN
[4046]533  nq = 0
534  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
535  DO it = 1, nt    !=== GET TRACERS NB AFTER EXPANSION + NEEDED KEYS (name, parent, type)
536  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
537    !--- Extract useful keys: parent name, type, component name
[5190]538    tr(it)%component = sname
539    CALL addKey('component', sname,  tr(it)%keys)
[4046]540
541    !--- Determine the number of tracers and parents ; coherence checking
[5001]542    ll = strCount( tname(it), ',', ntr)
543    ll = strCount(parent(it), ',', npr)
[4046]544
545    !--- Tagging tracers only can have multiple parents
[5001]546    lerr = npr /=1 .AND. TRIM(dType(it)) /= 'tag'
547    IF(lerr) THEN
[4046]548      msg1 = 'Check section "'//TRIM(sname)//'"'
[5001]549      IF(PRESENT(fname)) msg1 = TRIM(msg1)//' in file "'//TRIM(fname)//'"'
550      CALL msg(TRIM(msg1)//': "'//TRIM(tname(it))//'" has several parents but is not a tag', modname); RETURN
[4046]551    END IF
552    nq = nq + ntr*npr                 
553  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
554  END DO
555  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
556
557  ALLOCATE(ttr(nq))
558  iq = 1
559  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
560  DO it = 1, nt                                                      !=== EXPAND TRACERS AND PARENTS NAMES LISTS
561  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
[5001]562    ll = strParse( tname(it), ',', ta, ntr)                          !--- Number of tracers
563    ll = strParse(parent(it), ',', pa, npr)                          !--- Number of parents
564    DO ipr = 1, npr                                                  !--- Loop on parents list elts
565      DO itr = 1, ntr                                                !--- Loop on tracers list elts
[5190]566        ttr(iq)%keys%name = TRIM(ta(itr))
567        ttr(iq)%keys%key  = tr(it)%keys%key
568        ttr(iq)%keys%val  = tr(it)%keys%val
569        ttr(iq)%name      = TRIM(ta(itr))
570        ttr(iq)%parent    = TRIM(pa(ipr))
571        ttr(iq)%type      = dType(it)
572        ttr(iq)%component = sname
573        CALL addKey('name',      ta(itr),   ttr(iq)%keys)
574        CALL addKey('parent',    pa(ipr),   ttr(iq)%keys)
575        CALL addKey('type',      dType(it), ttr(iq)%keys)
576        CALL addKey('component', sname,     ttr(iq)%keys)
[5001]577        iq = iq + 1
[4046]578      END DO
579    END DO
580  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
581  END DO
582  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
583  DEALLOCATE(ta,pa)
584  CALL MOVE_ALLOC(FROM=ttr, TO=tr)
585
586END FUNCTION expandSection
587!==============================================================================================================================
588
[4328]589
[4046]590!==============================================================================================================================
[4325]591LOGICAL FUNCTION setGeneration(tr) RESULT(lerr)
[4046]592!------------------------------------------------------------------------------------------------------------------------------
593! Purpose: Determine, for each tracer of "tr(:)":
[5001]594!   * iGeneration: the generation number
595!   * gen0Name:    the generation 0 ancestor name
596!          Check also for orphan tracers (tracers without parent).
[4046]597!------------------------------------------------------------------------------------------------------------------------------
[5190]598  TYPE(trac_type),     INTENT(INOUT) :: tr(:)                        !--- Tracer derived type vector
[4328]599  INTEGER                            :: iq, jq, ig
[5004]600  CHARACTER(LEN=maxlen), ALLOCATABLE :: parent(:), tname(:)
[4046]601!------------------------------------------------------------------------------------------------------------------------------
[4328]602  CHARACTER(LEN=maxlen) :: modname
603  modname = 'setGeneration'
[5190]604  lerr = getKey('name',   tname,  ky=tr(:)%keys); IF(lerr) RETURN
605  lerr = getKey('parent', parent, ky=tr(:)%keys); IF(lerr) RETURN
[4328]606  DO iq = 1, SIZE(tr)
607    jq = iq; ig = 0
608    DO WHILE(parent(jq) /= tran0)
[5004]609      jq = strIdx(tname(:), parent(jq))
[5001]610      lerr = jq == 0
[5004]611      IF(fmsg('Orphan tracer "'//TRIM(tname(iq))//'"', modname, lerr)) RETURN
[4328]612      ig = ig + 1
613    END DO
[5190]614    tr(iq)%gen0Name = tname(jq)
615    tr(iq)%iGeneration = ig
616    CALL addKey('iGeneration',   ig,  tr(iq)%keys)
617    CALL addKey('gen0Name', tname(jq), tr(iq)%keys)
[4046]618  END DO
[4325]619END FUNCTION setGeneration
[4046]620!==============================================================================================================================
621
[4328]622
[4046]623!==============================================================================================================================
624LOGICAL FUNCTION checkTracers(tr, sname, fname) RESULT(lerr)
625!------------------------------------------------------------------------------------------------------------------------------
626! Purpose:
[5001]627!   * check for orphan tracers (without parent)
628!   * check wether the phases are known or not (elements of "known_phases")
[4046]629!------------------------------------------------------------------------------------------------------------------------------
[5190]630  TYPE(trac_type),            INTENT(IN) :: tr(:)                    !--- Tracer derived type vector
[4046]631  CHARACTER(LEN=*),           INTENT(IN) :: sname                    !--- Section name
632  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname                    !--- File name
[5001]633  CHARACTER(LEN=1) :: p
[4046]634  CHARACTER(LEN=maxlen) :: mesg
635  CHARACTER(LEN=maxlen) :: bp(SIZE(tr, DIM=1)), pha                  !--- Bad phases list, phases of current tracer
[5001]636  CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:)
637  INTEGER,               ALLOCATABLE ::  iGen(:)
[4046]638  INTEGER :: ip, np, iq, nq
639!------------------------------------------------------------------------------------------------------------------------------
[5001]640  CHARACTER(LEN=maxlen) :: modname
641  modname = 'checkTracers'
[4046]642  nq = SIZE(tr,DIM=1)                                                !--- Number of tracers lines
643  mesg = 'Check section "'//TRIM(sname)//'"'
644  IF(PRESENT(fname)) mesg=TRIM(mesg)//' in file "'//TRIM(fname)//'"'
[5190]645  lerr = getKey('iGeneration', iGen, tr(:)%keys);               IF(lerr) RETURN
646  lerr = getKey('name',       tname, tr(:)%keys);               IF(lerr) RETURN
[4046]647
648  !=== CHECK FOR ORPHAN TRACERS
[5001]649  lerr = checkList(tname, iGen==-1, mesg, 'tracers', 'orphan'); IF(lerr) RETURN
[4046]650
651  !=== CHECK PHASES
[5001]652  DO iq = 1, nq; IF(iGen(iq) /= 0) CYCLE                             !--- Generation O only is checked
[5190]653    IF(getKey(['phases','phase '], pha, iq, tr(:)%keys, lDisp=.FALSE.)) pha = 'g'   !--- Phase
[4046]654    np = LEN_TRIM(pha); bp(iq)=' '
[5001]655    DO ip = 1, np; p = pha(ip:ip); IF(INDEX(known_phases, p) == 0) bp(iq) = TRIM(bp(iq))//p; END DO
656    IF(TRIM(bp(iq)) /= '') bp(iq) = TRIM(tname(iq))//': '//TRIM(bp(iq))
[4046]657  END DO
[5001]658  lerr = checkList(bp, iGen == 0 .AND. bp /= '', mesg, 'tracers phases', 'unknown')
[4046]659END FUNCTION checkTracers
660!==============================================================================================================================
661
[4328]662
[4046]663!==============================================================================================================================
[4063]664LOGICAL FUNCTION checkUnique(tr, sname, fname) RESULT(lerr)
[4046]665!------------------------------------------------------------------------------------------------------------------------------
666! Purpose: Make sure that tracers are not repeated.
667!------------------------------------------------------------------------------------------------------------------------------
[5190]668  TYPE(trac_type),            INTENT(IN) :: tr(:)                    !--- Tracer derived type vector
[4046]669  CHARACTER(LEN=*),           INTENT(IN) :: sname                    !--- Section name
670  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname                    !--- File name
671!------------------------------------------------------------------------------------------------------------------------------
672  INTEGER :: ip, np, iq, nq, k
673  LOGICAL, ALLOCATABLE  :: ll(:)
[5001]674  CHARACTER(LEN=maxlen) :: mesg, phase, tdup(SIZE(tr,DIM=1))
675  CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), dType(:)
676  INTEGER,               ALLOCATABLE :: iGen(:)
677  CHARACTER(LEN=1) :: p
[4046]678!------------------------------------------------------------------------------------------------------------------------------
[5001]679  CHARACTER(LEN=maxlen) :: modname
680  modname = 'checkUnique'
[4046]681  mesg = 'Check section "'//TRIM(sname)//'"'
682  IF(PRESENT(fname)) mesg=TRIM(mesg)//' in file "'//TRIM(fname)//'"'
683  nq=SIZE(tr,DIM=1); lerr=.FALSE.                                    !--- Number of lines ; error flag
684  tdup(:) = ''
[5190]685  lerr = getKey('name',       tname, tr%keys); IF(lerr) RETURN
686  lerr = getKey('type',       dType, tr%keys); IF(lerr) RETURN
687  lerr = getKey('iGeneration', iGen, tr%keys); IF(lerr) RETURN
[5001]688  DO iq = 1, nq
689    IF(dType(iq) == 'tag') CYCLE                                     !--- Tags can be repeated
690    ll = tname==TRIM(tname(iq))                                      !--- Mask for current tracer name
691    IF(COUNT(ll) == 1) CYCLE                                         !--- Tracer is not repeated
692    IF(iGen(iq) > 0) THEN
693      tdup(iq) = tname(iq)                                           !--- gen>0: MUST be unique
[4046]694    ELSE
[5001]695      DO ip = 1, nphases; p = known_phases(ip:ip)                    !--- Loop on known phases
696        np = 0
697        DO k = 1, nq
698          IF(.NOT.ll(k)) CYCLE                                       !--- Skip tracers different from current one
[5190]699          IF(getKey(['phases','phase '], phase, k, tr%keys, lDisp=.FALSE.)) phase='g'!--- Get current phases
[5001]700          IF(INDEX(phase, p) /= 0) np = np + 1                       !--- One more appearance of current tracer with phase "p"
701        END DO
702        IF(np <= 1) CYCLE                                            !--- Regular case: no or a single appearance
703        tdup(iq) = TRIM(tdup(iq))//TRIM(phases_names(ip))            !--- Repeated phase
[4046]704        IF(ANY(tdup(1:iq-1) == tdup(iq))) tdup(iq)=''                !--- Avoid repeating same messages
705      END DO
706    END IF
[5001]707    IF(tdup(iq) /= '') tdup(iq)=TRIM(tname(iq))//' in '//TRIM(tdup(iq))//' phase(s)'
[4046]708  END DO
709  lerr = checkList(tdup, tdup/='', mesg, 'tracers', 'duplicated')
710END FUNCTION checkUnique
711!==============================================================================================================================
712
[4328]713
[4046]714!==============================================================================================================================
[5001]715LOGICAL FUNCTION expandPhases(tr) RESULT(lerr)
[4046]716!------------------------------------------------------------------------------------------------------------------------------
[4120]717! Purpose: Expand the phases in the tracers descriptor "tr". Phases are not repeated for a tracer, thanks to "checkUnique".
[4046]718!------------------------------------------------------------------------------------------------------------------------------
[5190]719  TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:)               !--- Tracer derived type vector
[4046]720!------------------------------------------------------------------------------------------------------------------------------
[5190]721  TYPE(trac_type),       ALLOCATABLE :: ttr(:)
[5001]722  INTEGER,               ALLOCATABLE ::  i0(:), iGen(:)
723  CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), gen0N(:), phase(:), parents(:), dType(:)
[5003]724  CHARACTER(LEN=maxlen)              ::  nam,     gen0Nm,   pha,      parent
[4120]725  CHARACTER(LEN=1) :: p
[4046]726  INTEGER :: ip, np, iq, jq, nq, it, nt, nc, i, n
[4301]727  LOGICAL :: lTag, lExt
[4046]728!------------------------------------------------------------------------------------------------------------------------------
[5001]729  CHARACTER(LEN=maxlen) :: modname
730  modname = 'expandPhases'
[4046]731  nq = SIZE(tr, DIM=1)
732  nt = 0
[5190]733  lerr = getKey('name',       tname, tr%keys); IF(lerr) RETURN       !--- Names of the tracers
734  lerr = getKey('gen0Name',   gen0N, tr%keys); IF(lerr) RETURN       !--- Names of the tracers of first generation
735  lerr = getKey('iGeneration', iGen, tr%keys); IF(lerr) RETURN       !--- Generation number
736  lerr = getKey('phases',     phase, tr%keys); IF(lerr) RETURN       !--- Phases names
737  lerr = getKey('parent',   parents, tr%keys); IF(lerr) RETURN       !--- Parents names
738  lerr = getKey('type',       dType, tr%keys); IF(lerr) RETURN       !--- Tracers types ('tracer' or 'tag')
[4046]739  DO iq = 1, nq                                                      !--- GET THE NUMBER OF TRACERS
[5001]740    IF(iGen(iq) /= 0) CYCLE                                          !--- Only deal with generation 0 tracers
741    nc = COUNT(gen0N == tname(iq) .AND. iGen /= 0)                   !--- Number of children of tr(iq)
742    np = LEN_TRIM(phase(iq))                                         !--- Number of phases   of tr(iq)
[4046]743    nt = nt + (1+nc) * np                                            !--- Number of tracers after expansion
744  END DO
[4120]745  ALLOCATE(ttr(nt))                                                  !--- Version  of "tr" after phases expansion
[4046]746  it = 1                                                             !--- Current "ttr(:)" index
747  DO iq = 1, nq                                                      !--- Loop on "tr(:)" indexes
[5001]748    lTag = dType(iq)=='tag'                                          !--- Current tracer is a tag
749    i0 = strFind(tname, TRIM(gen0N(iq)), n)                          !--- Indexes of first generation ancestor copies
750    np = SUM([( LEN_TRIM(phase(i0(i))), i = 1, n )], 1)              !--- Number of phases for current tracer tr(iq)
751    lExt = np > 1                                                    !--- Phase suffix only required if phases number is > 1
752    IF(lTag) lExt = lExt .AND. iGen(iq) > 0                          !--- No phase suffix for generation 0 tags
753    DO i = 1, n                                                      !=== LOOP ON GENERATION 0 ANCESTORS
[4120]754      jq = i0(i)                                                     !--- tr(jq): ith tracer with same gen 0 ancestor as tr(iq)
[5001]755      IF(iGen(iq) == 0) jq = iq                                      !--- Generation 0: count the current tracer phases only
756      pha = phase(jq)                                                !--- Phases list for tr(jq)
[4120]757      DO ip = 1, LEN_TRIM(pha)                                       !=== LOOP ON PHASES LISTS
758        p = pha(ip:ip)
[5001]759        nam = tname(iq)                                              !--- Tracer name (regular case)
760        IF(lTag) nam = TRIM(parents(iq))                             !--- Parent name (tagging case)
[4301]761        IF(lExt) nam = addPhase(nam, p )                             !--- Phase extension needed
[5001]762        IF(lTag) nam = TRIM(nam)//'_'//TRIM(tname(iq))               !--- <parent>_<name> for tags
[4046]763        ttr(it) = tr(iq)                                             !--- Same <key>=<val> pairs
[5190]764        ttr(it)%name      = TRIM(nam)                                !--- Name with possibly phase suffix
765        ttr(it)%keys%name = TRIM(nam)                                !--- Name inside the keys decriptor
766        ttr(it)%phase     = p                                        !--- Single phase entry
767        CALL addKey('name', nam, ttr(it)%keys)
768        CALL addKey('phase', p,  ttr(it)%keys)
[5001]769        IF(lExt) THEN
770          parent = parents(iq); IF(iGen(iq) > 0) parent = addPhase(parent, p)
771          gen0Nm =   gen0N(iq); IF(iGen(iq) > 0) gen0Nm = addPhase(gen0Nm, p)
[5190]772          ttr(it)%parent   = parent
773          ttr(it)%gen0Name = gen0Nm
774          CALL addKey('parent',   parent, ttr(it)%keys)
775          CALL addKey('gen0Name', gen0Nm, ttr(it)%keys)
[4046]776        END IF
[4120]777        it = it+1
[4046]778      END DO
[5001]779      IF(iGen(iq) == 0) EXIT                                         !--- Break phase loop for gen 0
[4046]780    END DO
781  END DO
782  CALL MOVE_ALLOC(FROM=ttr, TO=tr)
[5190]783  CALL delKey(['phases'],tr)                                         !--- Remove few keys entries
[4046]784
[5001]785END FUNCTION expandPhases
[4046]786!==============================================================================================================================
787
[4328]788
[4046]789!==============================================================================================================================
790SUBROUTINE sortTracers(tr)
791!------------------------------------------------------------------------------------------------------------------------------
792! Purpose: Sort tracers:
[4120]793!  * Put water at the beginning of the vector, in the "known_phases" order.
[4046]794!  * lGrowGen == T: in ascending generations numbers.
[4325]795!  * lGrowGen == F: tracer + its children sorted by growing generation, one after the other.
[4063]796!   TO BE ADDED IF NECESSARY: HIGHER MOMENTS AT THE END
[4046]797!------------------------------------------------------------------------------------------------------------------------------
[5190]798  TYPE(trac_type), INTENT(INOUT) :: tr(:)                            !--- Tracer derived type vector
[4046]799!------------------------------------------------------------------------------------------------------------------------------
[5190]800  TYPE(trac_type),       ALLOCATABLE :: tr2(:)
801  INTEGER,               ALLOCATABLE :: iy(:), iz(:)
802  INTEGER,               ALLOCATABLE ::  iGen(:)
[5001]803  CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), gen0N(:)
804  INTEGER :: ig, ng, iq, jq, ip, nq, n, ix(SIZE(tr)), k
805  LOGICAL :: lerr
[4233]806!  tr2 is introduced in order to cope with a bug in gfortran 4.8.5 compiler
807!------------------------------------------------------------------------------------------------------------------------------
[5190]808  lerr = getKey('iGeneration', iGen, tr%keys); IF(lerr) RETURN       !--- Generation number
[4063]809  nq = SIZE(tr)
810  DO ip = nphases, 1, -1
[5190]811    lerr = getKey('name',     tname, tr%keys); IF(lerr) RETURN       !--- Names of the tracers of first generation
[5001]812    iq = strIdx(tname, addPhase('H2O', ip))
[4120]813    IF(iq == 0) CYCLE
[4233]814    tr2 = tr(:)
815    tr = [tr2(iq), tr2(1:iq-1), tr2(iq+1:nq)]
[4063]816  END DO
[4046]817  IF(lSortByGen) THEN
[4120]818    iq = 1
[5001]819    ng = MAXVAL(iGen, MASK=.TRUE., DIM=1)                            !--- Number of generations
[4046]820    DO ig = 0, ng                                                    !--- Loop on generations
[5001]821      iy = PACK([(k, k=1, nq)], MASK=iGen(:) == ig)                  !--- Generation ig tracers indexes
[4046]822      n = SIZE(iy)
823      ix(iq:iq+n-1) = iy                                             !--- Stack growing generations idxs
824      iq = iq + n
825    END DO
826  ELSE
[5190]827    lerr = getKey('gen0Name',   gen0N, tr%keys); IF(lerr) RETURN     !--- Names of the tracers    iq = 1
[4120]828    DO jq = 1, nq                                                    !--- Loop on generation 0 tracers
[5001]829      IF(iGen(jq) /= 0) CYCLE                                        !--- Skip generations /= 0
[4120]830      ix(iq) = jq                                                    !--- Generation 0 ancestor index first
831      iq = iq + 1                                                    !--- Next "iq" for next generations tracers
[5001]832      iy = strFind(gen0N(:), TRIM(tname(jq)))                        !--- Indices of "tr(jq)" children in "tr(:)"
833      ng = MAXVAL(iGen(iy), MASK=.TRUE., DIM=1)                      !--- Number of generations of the "tr(jq)" family
[4120]834      DO ig = 1, ng                                                  !--- Loop   on generations of the "tr(jq)" family
[5001]835        iz = find(iGen(iy), ig, n)                                   !--- Indices of the tracers "tr(iy(:))" of generation "ig"
[4046]836        ix(iq:iq+n-1) = iy(iz)                                       !--- Same indexes in "tr(:)"
837        iq = iq + n
838      END DO
839    END DO
840  END IF
841  tr = tr(ix)                                                        !--- Reorder the tracers
842END SUBROUTINE sortTracers
843!==============================================================================================================================
844
[4325]845
[4046]846!==============================================================================================================================
847LOGICAL FUNCTION mergeTracers(sections, tr) RESULT(lerr)
848  TYPE(dataBase_type),  TARGET, INTENT(IN)  :: sections(:)
[5190]849  TYPE(trac_type), ALLOCATABLE, INTENT(OUT) ::       tr(:)
850  TYPE(trac_type), POINTER ::   t1(:),   t2(:)
851  TYPE(keys_type), POINTER ::   k1(:),   k2(:)
[4046]852  INTEGER,     ALLOCATABLE :: ixct(:), ixck(:)
[5001]853  INTEGER :: is, ik, ik1, ik2, nk2, i1, i2, nt2
[4046]854  CHARACTER(LEN=maxlen) :: s1, v1, v2, tnam, knam, modname
[5001]855  CHARACTER(LEN=maxlen), ALLOCATABLE :: keys(:), n1(:), n2(:)
[4046]856  modname = 'mergeTracers'
857  lerr = .FALSE.
[5001]858  keys = ['parent     ', 'type       ', 'iGeneration']               !--- Mandatory keys
[5190]859  t1 => sections(1)%trac(:); k1 => t1(:)%keys                        !--- Alias: first tracers section, corresponding keys
860  lerr = getKey('name', n1, k1); IF(lerr) RETURN                     !--- Names of the tracers
[4046]861  tr = t1
862  !----------------------------------------------------------------------------------------------------------------------------
863  DO is=2,SIZE(sections)                                             !=== SEVERAL SECTIONS: MERGE THEM
864  !----------------------------------------------------------------------------------------------------------------------------
865    t2  => sections(is)%trac(:)                                      !--- Alias: current tracers section
[5190]866    k2  => t2(:)%keys
867    lerr = getKey('name', n2, k2); IF(lerr) RETURN                   !--- Names of the tracers
[4046]868    nt2  = SIZE(t2(:), DIM=1)                                        !--- Number of tracers in section
[5001]869    ixct = strIdx(n1(:), n2(:))                                      !--- Indexes of common tracers
[4046]870    tr = [tr, PACK(t2, MASK= ixct==0)]                               !--- Append with new tracers
871    IF( ALL(ixct == 0) ) CYCLE                                       !--- No common tracers => done
872    CALL msg('Tracers defined in previous sections and duplicated in "'//TRIM(sections(is)%name)//'":', modname)
[5001]873    CALL msg(n1(PACK(ixct, MASK = ixct/=0)), modname, nmax=128)      !--- Display duplicates (the 128 first at most)
[4046]874    !--------------------------------------------------------------------------------------------------------------------------
[5190]875    DO i2=1,nt2; tnam = TRIM(t2(i2)%name)                            !=== LOOP ON COMMON TRACERS
[4046]876    !--------------------------------------------------------------------------------------------------------------------------
877      i1 = ixct(i2); IF(i1 == 0) CYCLE                               !--- Idx in t1(:) ; skip new tracers
878
879      !=== CHECK WETHER ESSENTIAL KEYS ARE IDENTICAL OR NOT
880      s1=' of "'//TRIM(tnam)//'" in "'//TRIM(sections(is)%name)//'" not matching previous value'
[5001]881      DO ik = 1, SIZE(keys)
[5190]882        lerr = getKey(keys(ik), v1, i1, k1)
883        lerr = getKey(keys(ik), v2, i2, k2)
[5001]884        lerr = v1 /= v2; IF(fmsg(TRIM(keys(ik))//TRIM(s1), modname, lerr)) RETURN
885      END DO
[4046]886
[5190]887      !=== GET THE INDICES IN tr(i2)%keys%key(:) OF THE KEYS ALSO PRESENT IN tr(i1)%keys%key(:)
888      nk2  =   SIZE(k2(i2)%key(:))                                   !--- Keys number in current section
889      ixck = strIdx(k1(i1)%key(:), k2(i2)%key(:))                    !--- Common keys indexes
890      !--- APPEND THE NEW KEYS PAIRS IN tr(i1)%keys%key(:)
891      tr(i1)%keys%key = [ tr(i1)%keys%key, PACK(tr(i2)%keys%key, MASK = ixck==0)]
892      tr(i1)%keys%val = [ tr(i1)%keys%val, PACK(tr(i2)%keys%val, MASK = ixck==0)]
[4046]893
[5001]894      !=== KEEP TRACK OF THE COMPONENTS NAMES: COMA-SEPARATED LIST
[5190]895      lerr = getKey('component', v1, i1, k1)
896      lerr = getKey('component', v2, i2, k2)
897      tr(i1)%component = TRIM(v1)//','//TRIM(v2)
898      CALL addKey('component', TRIM(v1)//','//TRIM(v2), tr(i1)%keys)
[4046]899
[5001]900      !=== FOR TRACERS COMMON TO PREVIOUS AND CURRENT SECTIONS: CHECK WETHER SOME KEYS HAVE DIFFERENT VALUES ; KEEP OLD ONE
901      DO ik2 = 1, nk2                                                !--- Collect the corresponding indices
902        ik1 = ixck(ik2); IF(ik1 == 0) CYCLE
[5190]903        IF(k1(i1)%val(ik1) == k2(i2)%val(ik2)) ixck(ik2)=0
[4046]904      END DO
[5001]905      IF(ALL(ixck==0)) CYCLE                                         !--- No identical keys with /=values => nothing to display
906      CALL msg('Key(s)'//TRIM(s1), modname)                          !--- Display the  keys with /=values (names list)
907      DO ik2 = 1, nk2                                                !--- Loop on keys found in both t1(:) and t2(:)
[5190]908        knam = k2(i2)%key(ik2)                                       !--- Name of the current key
[5001]909        ik1 = ixck(ik2)                                              !--- Corresponding index in t1(:)
910        IF(ik1 == 0) CYCLE                                           !--- New keys are skipped
[5190]911        v1 = k1(i1)%val(ik1); v2 = k2(i2)%val(ik2)                   !--- Key values in t1(:) and t2(:)
[4046]912        CALL msg(' * '//TRIM(knam)//'='//TRIM(v2)//' ; previous value kept:'//TRIM(v1), modname)
913      END DO
914      !------------------------------------------------------------------------------------------------------------------------
915    END DO
916    !--------------------------------------------------------------------------------------------------------------------------
917  END DO
918  CALL sortTracers(tr)
919
920END FUNCTION mergeTracers
921!==============================================================================================================================
922
923!==============================================================================================================================
[5001]924LOGICAL FUNCTION cumulTracers(sections, tr, lRename) RESULT(lerr)
[4046]925  TYPE(dataBase_type),  TARGET, INTENT(IN)  :: sections(:)
[5190]926  TYPE(trac_type), ALLOCATABLE, INTENT(OUT) ::       tr(:)
[5001]927  LOGICAL,            OPTIONAL, INTENT(IN)  :: lRename               !--- .TRUE.: add a section suffix to identical names
[5003]928  CHARACTER(LEN=maxlen)  :: tnam_new, modname
[5001]929  CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), parent(:), comp(:)
930  INTEGER :: iq, jq, is
931  modname = 'cumulTracers'
932  lerr = .FALSE.
933  tr = [( sections(is)%trac(:), is = 1, SIZE(sections) )]            !--- Concatenated tracers vector
934  IF(PRESENT(lRename)) THEN; IF(lRename) RETURN; END IF              !--- No renaming: finished
[5190]935  lerr = getKey('name',     tname, tr%keys); IF(lerr) RETURN         !--- Names
936  lerr = getKey('parent',  parent, tr%keys); IF(lerr) RETURN         !--- Parents
937  lerr = getKey('component', comp, tr%keys); IF(lerr) RETURN         !--- Component name
[4046]938  !----------------------------------------------------------------------------------------------------------------------------
[5001]939  DO iq = 1, SIZE(tr); IF(COUNT(tname == tname(iq)) == 1) CYCLE      !=== LOOP ON TRACERS
[4046]940  !----------------------------------------------------------------------------------------------------------------------------
[5001]941    tnam_new = TRIM(tname(iq))//'_'//TRIM(comp(iq))                  !--- Same with section extension
[5190]942    CALL addKey('name', tnam_new, tr(iq)%keys)                       !--- Modify tracer name
943    tr(iq)%name = TRIM(tnam_new)                                     !--- Modify tracer name
[4046]944    !--------------------------------------------------------------------------------------------------------------------------
[5001]945    DO jq = 1, SIZE(tr); IF(parent(jq) /= tname(iq)) CYCLE           !=== LOOP ON TRACERS PARENTS
[4046]946    !--------------------------------------------------------------------------------------------------------------------------
[5190]947      CALL addKey('parent', tnam_new, tr(jq)%keys)                   !--- Modify tracer name
948      tr(jq)%parent = TRIM(tnam_new)                                 !--- Modify tracer name
[4046]949    !--------------------------------------------------------------------------------------------------------------------------
950    END DO
951  !----------------------------------------------------------------------------------------------------------------------------
952  END DO
953  !----------------------------------------------------------------------------------------------------------------------------
954  CALL sortTracers(tr)
955END FUNCTION cumulTracers
956!==============================================================================================================================
957
[4063]958
[4046]959!==============================================================================================================================
[5001]960LOGICAL  FUNCTION  dispTraSection(message, sname, modname) RESULT(lerr)
[4046]961  CHARACTER(LEN=*), INTENT(IN) :: message, sname, modname
[5001]962  CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:,:), n(:), tmp(:)
963  CHARACTER(LEN=maxlen) :: p
[4046]964  INTEGER :: idb, iq, nq
965  idb = strIdx(dBase(:)%name, sname); IF(idb == 0) RETURN
[5001]966  nq = SIZE(dBase(idb)%trac)
967  p = ''
[5002]968  CALL append(['iq'],     .TRUE. ); IF(lerr) RETURN
969  CALL append(['name'],   .TRUE. ); IF(lerr) RETURN
970  CALL append(['phases','phase '], .FALSE., 'pha'); IF(lerr) RETURN
971  CALL append(['hadv'],   .TRUE. ); IF(lerr) RETURN
972  CALL append(['vadv'],   .TRUE. ); IF(lerr) RETURN
973  CALL append(['parent'], .FALSE.); IF(lerr) RETURN
974  CALL append(['iGen'],   .FALSE.); IF(lerr) RETURN
[4046]975  CALL msg(TRIM(message)//':', modname)
[5001]976  lerr = dispTable(p, n, s, nColMax=maxTableWidth, nHead=2, sub=modname); IF(lerr) RETURN
977
978CONTAINS
979
980SUBROUTINE append(nam, lMandatory, snam)
981! Test whether key named "nam(:)" is available.
982!  * yes: - get its value for all species in "tmp(:)" and append table "s(:,:)" with it
983!         - append titles list with "nam(1)" (or, if specified, "snam", usually a short name).
984!  * no:  return to calling routine with an error flag if the required key is mandatory
985  CHARACTER(LEN=*),           INTENT(IN) :: nam(:)
986  LOGICAL,                    INTENT(IN) :: lMandatory
987  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: snam
988  INTEGER :: m
[5003]989  CHARACTER(LEN=maxlen), ALLOCATABLE :: n0(:)
[5001]990  CHARACTER(LEN=maxlen) :: nm
[5353]991  CHARACTER(LEN=maxlen) :: tmp2(nq)
992
[5001]993  lerr = .FALSE.
994  IF(nam(1) == 'iq') THEN
[5353]995    tmp2 = int2str([(iq, iq=1, nq)])
996    tmp = tmp2
[4120]997  ELSE
[5190]998    lerr = getKey(nam, tmp, dBase(idb)%trac(:)%keys, lDisp=lMandatory)
[4120]999  END IF
[5001]1000  IF(lerr) THEN; lerr = lMandatory; RETURN; END IF
1001  nm = nam(1); IF(PRESENT(snam)) nm = snam
1002  p = TRIM(p)//'s'
1003  IF(ALLOCATED(s)) THEN; s = cat(s, tmp); ELSE; ALLOCATE(s(nq,1)); s(:,1) = tmp; END IF
1004  IF(ALLOCATED(n)) THEN; m = SIZE(n); ALLOCATE(n0(m+1)); n0(1:m)=n; n0(m+1)=nm; CALL MOVE_ALLOC(FROM=n0, TO=n)
1005  ELSE; n=nam(1:1); END IF
1006END SUBROUTINE append
1007
[4046]1008END FUNCTION dispTraSection
1009!==============================================================================================================================
1010
1011
1012!==============================================================================================================================
[5001]1013!=== CREATE TRACER(S) ALIAS: SCALAR/VECTOR FROM NAME(S) OR INDICE(S) ==========================================================
[4046]1014!==============================================================================================================================
[5001]1015LOGICAL FUNCTION aliasTracer(tname, trac, alias) RESULT(lerr)                  !=== TRACER NAMED "tname" - SCALAR
1016  CHARACTER(LEN=*),         INTENT(IN)  :: tname
[5190]1017  TYPE(trac_type), TARGET,  INTENT(IN)  :: trac(:)
1018  TYPE(trac_type), POINTER, INTENT(OUT) :: alias
[4046]1019  INTEGER :: it
[5001]1020  CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:)
1021  alias => NULL()
[5190]1022  lerr = getKey('name', tnames, trac(:)%keys)
[5001]1023  it = strIdx(tnames, tname)
1024  lerr = it /= 0; IF(.NOT.lerr) alias => trac(it)
[4046]1025END FUNCTION aliasTracer
[4301]1026!==============================================================================================================================
[5001]1027LOGICAL FUNCTION trSubset_Indx(trac, idx, alias) RESULT(lerr)                  !=== TRACERS WITH INDICES "idx(:)" - VECTOR
[5190]1028  TYPE(trac_type), ALLOCATABLE, INTENT(IN)  ::  trac(:)
[5001]1029  INTEGER,                      INTENT(IN)  ::   idx(:)
[5190]1030  TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: alias(:)
[5001]1031  alias = trac(idx)
1032  lerr = indexUpdate(alias)
[4046]1033END FUNCTION trSubset_Indx
1034!------------------------------------------------------------------------------------------------------------------------------
[5001]1035LOGICAL FUNCTION trSubset_Name(trac, tname, alias) RESULT(lerr)                !=== TRACERS NAMED "tname(:)" - VECTOR
[5190]1036  TYPE(trac_type), ALLOCATABLE, INTENT(IN)  ::  trac(:)
[5001]1037  CHARACTER(LEN=*),             INTENT(IN)  :: tname(:)
[5190]1038  TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: alias(:)
[5001]1039  CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:)
[5190]1040  lerr = getKey('name', tnames, trac(:)%keys)
[5001]1041  alias = trac(strIdx(tnames, tname))
1042  lerr = indexUpdate(alias)
[4046]1043END FUNCTION trSubset_Name
[4301]1044!==============================================================================================================================
[5001]1045LOGICAL FUNCTION trSubset_gen0Name(trac, gen0Nm, alias) RESULT(lerr)           !=== TRACERS OF COMMON 1st GENERATION ANCESTOR
[5190]1046  TYPE(trac_type), ALLOCATABLE, INTENT(IN)  :: trac(:)
[5001]1047  CHARACTER(LEN=*),             INTENT(IN)  :: gen0Nm
[5190]1048  TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: alias(:)
[5001]1049  CHARACTER(LEN=maxlen), ALLOCATABLE :: gen0N(:)
[5190]1050  lerr = getKey('gen0Name', gen0N, trac(:)%keys)
[5001]1051  alias = trac(strFind(delPhase(gen0N), gen0Nm))
1052  lerr = indexUpdate(alias)
[4046]1053END FUNCTION trSubset_gen0Name
[4301]1054!==============================================================================================================================
[4046]1055
1056
1057!==============================================================================================================================
[5190]1058!=== UPDATE THE INDEXES iqParent, iqDescend AND iGeneration IN THE TRACERS DESCRIPTOR LIST "tr" (USEFULL FOR SUBSETS) =========
[4046]1059!==============================================================================================================================
[5001]1060LOGICAL FUNCTION indexUpdate(tr) RESULT(lerr)
[5190]1061  TYPE(trac_type), INTENT(INOUT) :: tr(:)
[5001]1062  INTEGER :: iq, jq, nq, ig, nGen
1063  INTEGER,               ALLOCATABLE :: iqDescen(:), ix(:), iy(:)
1064  CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:), parent(:)
[5003]1065  INTEGER,       DIMENSION(SIZE(tr)) :: iqParent, iGen
[5190]1066  lerr = getKey('name',   tnames, tr%keys); IF(lerr) RETURN          !--- Names
1067  lerr = getKey('parent', parent, tr%keys); IF(lerr) RETURN          !--- Parents
[5001]1068  nq = SIZE(tr)
1069
[5190]1070  !=== iqParent, iGeneration
[5001]1071  DO iq = 1, nq; iGen(iq) = 0; jq = iq
[5004]1072    iqParent(iq) = strIdx(tnames, parent(iq))
[5001]1073    DO; jq = strIdx(tnames, parent(jq)); IF(jq == 0) EXIT; iGen(iq) = iGen(iq) + 1; END DO
[5190]1074    CALL addKey('iqParent',   parent(iq), tr(iq)%keys)
1075    CALL addKey('iqGeneration', iGen(iq), tr(iq)%keys)
[5618]1076    tr(iq)%iqParent = iqParent(iq)
[5001]1077  END DO
1078
[5004]1079  !=== nqChildren, iqDescen, nqDescen
[5001]1080  nGen = MAXVAL(iGen, MASK=.TRUE.)
1081  DO iq = 1, nq
1082    ix = [iq]; ALLOCATE(iqDescen(0))
1083    DO ig = iGen(iq)+1, nGen
1084      iy = find(iqParent, ix); iqDescen = [iqDescen, iy]; ix = iy
1085      IF(ig /= iGen(iq)+1) CYCLE
[5190]1086      CALL addKey('nqChildren', SIZE(iqDescen), tr(iq)%keys)
1087      tr(iq)%nqChildren = SIZE(iqDescen)
[4120]1088    END DO
[5190]1089    CALL addKey('iqDescen', strStack(int2str(iqDescen)), tr(iq)%keys)
1090    CALL addKey('nqDescen',             SIZE(iqDescen),  tr(iq)%keys)
1091    tr(iq)%iqDescen =      iqDescen
1092    tr(iq)%nqDescen = SIZE(iqDescen)
[5001]1093    DEALLOCATE(iqDescen)
[4046]1094  END DO
[5001]1095END FUNCTION indexUpdate
[4301]1096!==============================================================================================================================
[4046]1097 
1098 
1099!==============================================================================================================================
[5190]1100!=== READ FILE "fnam" TO APPEND THE "dBase" TRACERS DATABASE WITH AS MUCH SECTIONS AS PARENTS NAMES IN "isot(:)%parent":   ====
1101!===  * Each section dBase(i)%name contains the isotopes "dBase(i)%trac(:)" descending on "dBase(i)%name"="iso(i)%parent"  ====
[4046]1102!===  * For each isotopes class, the <key>=<val> vector of each tracer is moved into the isotopes descriptor "isot"        ====
1103!=== NOTES:                                                                                                                ====
[5001]1104!===  * Most of the "isot" components have been defined in the calling routine (processIsotopes):                          ====
[5190]1105!===      parent,  nzone, zone(:),  niso, keys(:)%name,  ntiso, trac(:),  nphas, phas,  iqIsoPha(:,:),  itZonPhi(:,:)      ====
[4046]1106!===  * Same syntax for isotopes file and "tracer.def": a tracers section contains one line for each of its isotopes       ====
1107!===  * Each tracers section can contain a "params" virtual isotope line of isotopes parameters default values             ====
1108!===  * In case keys are found both in the "params" section and the "*.def" file, the later value is retained              ====
1109!===  * On each isotope line, defined keys can be used for other keys defintions (single level depth substitution)         ====
1110!===  * The routine gives an error if a required isotope is not available in the database stored in "fnam"                 ====
1111!==============================================================================================================================
[5001]1112LOGICAL FUNCTION readIsotopesFile(fnam, isot) RESULT(lerr)
[4046]1113  CHARACTER(LEN=*),        INTENT(IN)    :: fnam                     !--- Input file name
[5190]1114  TYPE(isot_type), TARGET, INTENT(INOUT) :: isot(:)                  !--- Isotopes descriptors (field %parent must be defined!)
[4454]1115  LOGICAL :: lFound
[4363]1116  INTEGER :: is, iis, it, idb, ndb, nb0
[5190]1117  CHARACTER(LEN=maxlen), ALLOCATABLE :: vals(:)
[4363]1118  CHARACTER(LEN=maxlen)              :: modname
[5190]1119  TYPE(trac_type),           POINTER ::   tt(:), t
[4046]1120  TYPE(dataBase_type),   ALLOCATABLE ::  tdb(:)
1121  modname = 'readIsotopesFile'
1122
1123  !--- THE INPUT FILE MUST BE PRESENT
[5190]1124  INQUIRE(FILE=TRIM(fnam), EXIST=lFound); lerr = .NOT.lFound
1125  IF(fmsg('Missing isotopes parameters file "'//TRIM(fnam)//'"', modname, lerr)) RETURN
[4046]1126
[5190]1127  !--- READ THE FILE SECTIONS, ONE EACH PARENT TRACER
[4046]1128  nb0 = SIZE(dBase, DIM=1)+1                                         !--- Next database element index
[5190]1129  lerr = readSections(fnam,strStack(isot(:)%parent,'|')); IF(lerr) RETURN !--- Read sections, one each parent tracer
[4046]1130  ndb = SIZE(dBase, DIM=1)                                           !--- Current database size
1131  DO idb = nb0, ndb
[4301]1132    iis = idb-nb0+1
[4046]1133
1134    !--- GET FEW GLOBAL KEYS FROM "def" FILES AND ADD THEM TO THE 'params' SECTION
[5190]1135    CALL addKeysFromDef(dBase(idb)%trac, 'params')
[4046]1136
1137    !--- SUBSTITUTE THE KEYS DEFINED IN THE 'params' VIRTUAL TRACER ; SUBSTITUTE LOCAL KEYS ; REMOVE 'params' VIRTUAL TRACER
[5190]1138    CALL subDefault(dBase(idb)%trac, 'params', .TRUE.)
[4046]1139
[5190]1140    tt => dBase(idb)%trac
1141
[4046]1142    !--- REDUCE THE EXPRESSIONS TO OBTAIN SCALARS AND TRANSFER THEM TO THE "isot" ISOTOPES DESCRIPTORS VECTOR
1143    DO it = 1, SIZE(dBase(idb)%trac)
1144      t => dBase(idb)%trac(it)
[5190]1145      is = strIdx(isot(iis)%keys(:)%name, t%name)                    !--- Index in "isot(iis)%keys(:)%name" of isotope "t%name"
[4046]1146      IF(is == 0) CYCLE
[5190]1147      lerr = ANY(reduceExpr(t%keys%val, vals)); IF(lerr) RETURN      !--- Reduce expressions ; detect non-numerical elements
1148      isot(iis)%keys(is)%key = t%keys%key
[4325]1149      isot(iis)%keys(is)%val = vals
[4046]1150    END DO
1151
1152    !--- CHECK FOR MISSING ISOTOPES (NO KEYS ALLOCATED)
[5190]1153    lerr = checkList(isot(iis)%keys(:)%name, .NOT.[( ALLOCATED(isot(iis)%keys(is)%key), is=1, SIZE(isot(iis)%keys) )], &
[5001]1154                     'Check file "'//TRIM(fnam)//'" in section "'//TRIM(dBase(idb)%name)//'"', 'isotopes', 'missing')
1155    IF(lerr) RETURN
[4046]1156  END DO
1157
1158  !--- CLEAN THE DATABASE ENTRIES
1159  IF(nb0 == 1) THEN
1160    DEALLOCATE(dBase); ALLOCATE(dBase(0))
1161  ELSE
1162    ALLOCATE(tdb(nb0-1)); tdb(1:nb0-1)=dBase(1:nb0-1); CALL MOVE_ALLOC(FROM=tdb, TO=dBase)
1163  END IF
[4120]1164
1165  !--- GET THE isoCheck ENTRY FROM THE *.DEF FILES (MIGHT BE CHANGED TO A CLASS-DEPENDANT KEYWORD)
[5190]1166  CALL get_in('ok_iso_verif', isot(strIdx(isot%parent, 'H2O'))%check, .FALSE.)
[4120]1167
[4325]1168  lerr = dispIsotopes()
[4046]1169
[4325]1170CONTAINS
1171
1172!------------------------------------------------------------------------------------------------------------------------------
1173LOGICAL FUNCTION dispIsotopes() RESULT(lerr)
1174  INTEGER :: ik, nk, ip, it, nt
1175  CHARACTER(LEN=maxlen) :: prf
[5190]1176  CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:), val(:,:)
[4325]1177  CALL msg('Isotopes parameters read from file "'//TRIM(fnam)//'":', modname)
[5190]1178  DO ip = 1, SIZE(isot)                                              !--- Loop on parents tracers
[4325]1179    nk = SIZE(isot(ip)%keys(1)%key)                                  !--- Same keys for each isotope
1180    nt = SIZE(isot(ip)%keys)                                         !--- Number of isotopes
1181    prf = 'i'//REPEAT('s',nk+1)                                      !--- Profile for table printing
1182    ALLOCATE(ttl(nk+2), val(nt,nk+1))
1183    ttl(1:2) = ['it  ','name']; ttl(3:nk+2) = isot(ip)%keys(1)%key(:)!--- Titles line with keys names
[5190]1184    val(:,1) = isot(ip)%keys(:)%name                                 !--- Values table 1st column: isotopes names 
[4325]1185    DO ik = 1, nk
1186      DO it = 1, nt
1187        val(it,ik+1) = isot(ip)%keys(it)%val(ik)                     !--- Other columns: keys values
1188      END DO
1189    END DO
[5001]1190    lerr = dispTable(prf, ttl, val, cat([(it,it=1,nt)]), rFmt='(EN8.4)', nColMax=maxTableWidth, nHead=2, sub=modname)
1191    IF(fmsg('Problem with the table content', modname, lerr)) RETURN
[4325]1192    DEALLOCATE(ttl, val)
1193  END DO       
1194END FUNCTION dispIsotopes
1195!------------------------------------------------------------------------------------------------------------------------------
1196
[5001]1197END FUNCTION readIsotopesFile
[4046]1198!==============================================================================================================================
1199
[4301]1200
[4046]1201!==============================================================================================================================
1202!=== IF ISOTOPES (2ND GENERATION TRACERS) ARE DETECTED:                                                                     ===
1203!===    * COMPUTE MOST OF THE RELATED QUANTITIES ("isot" COMPONENTS).                                                       ===
[5190]1204!===    * COMPUTE FEW ISOTOPES-DEDICATED "trac" COMPONENTS                                                                  ===
1205!===    * CALL readIsotopesFile TO GET PHYSICAL QUANTITIES (<key>=<val> PAIRS)                                              ===
1206!===      NOTE: THIS IS DONE HERE (IN A ROUTINE CALLED BY THE DYNAMIC), BECAUSE THE DYNAMIC NEEDS FEW PHYSICAL PARAMETERS.  ===
[4046]1207!==============================================================================================================================
[5190]1208LOGICAL FUNCTION processIsotopes(iNames) RESULT(lerr)
1209  CHARACTER(LEN=maxlen), TARGET, OPTIONAL, INTENT(IN)  :: iNames(:)
1210  CHARACTER(LEN=maxlen), ALLOCATABLE :: p(:), str(:)                 !--- Temporary storage
1211  CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), parent(:), dType(:), phase(:), gen0N(:)
1212  CHARACTER(LEN=maxlen) :: iName, modname
1213  CHARACTER(LEN=1)   :: ph                                           !--- Phase
1214  INTEGER, ALLOCATABLE ::  iGen(:)
1215  INTEGER :: ic, ip, iq, it, iz
1216  LOGICAL, ALLOCATABLE :: ll(:)                                      !--- Mask
1217  TYPE(trac_type), POINTER   ::  t(:), t1
1218  TYPE(isot_type), POINTER   ::  i
[5001]1219
[4193]1220  lerr = .FALSE.
[4325]1221  modname = 'readIsotopesFile'
[4046]1222
[5190]1223  t => tracers
[4046]1224
[5190]1225  lerr = getKey('name',       tname, t%keys); IF(lerr) RETURN       !--- Names
1226  lerr = getKey('parent',    parent, t%keys); IF(lerr) RETURN       !--- Parents
1227  lerr = getKey('type',       dType, t%keys); IF(lerr) RETURN       !--- Tracer type
1228  lerr = getKey('phase',      phase, t%keys); IF(lerr) RETURN       !--- Phase
1229  lerr = getKey('gen0Name',   gen0N, t%keys); IF(lerr) RETURN       !--- 1st generation ancestor name
1230  lerr = getKey('iGeneration', iGen, t%keys); IF(lerr) RETURN       !--- Generation number
1231
[4301]1232  !--- GET FROM "tracers" THE FULL LIST OF AVAILABLE ISOTOPES CLASSES
[5190]1233  p = PACK(delPhase(parent), MASK = dType=='tracer' .AND. iGen==1)
1234  CALL strReduce(p, nbIso)
[4046]1235
[5190]1236  !--- CHECK WHETHER NEEDED ISOTOPES CLASSES "iNames" ARE AVAILABLE OR NOT
1237  IF(PRESENT(iNames)) THEN
1238    DO it = 1, SIZE(iNames)
1239      lerr = ALL(p /= iNames(it))
1240      IF(fmsg('No isotopes class "'//TRIM(iNames(it))//'" found among tracers', modname, lerr)) RETURN
[4325]1241    END DO
[5190]1242    p = iNames; nbIso = SIZE(p)
[4325]1243  END IF
[5190]1244  IF(ALLOCATED(isotopes)) DEALLOCATE(isotopes)
1245  ALLOCATE(isotopes(nbIso))
[4325]1246
[4046]1247  IF(nbIso==0) RETURN                                                !=== NO ISOTOPES: FINISHED
1248
1249  !--- ISOTOPES RELATED VARIABLES ; NULL OR EMPTY IF NO ISOTOPES
[5190]1250  isotopes(:)%parent = p
1251  DO ic = 1, SIZE(p)                                                 !--- Loop on isotopes classes
1252    i => isotopes(ic)
1253    iname = i%parent                                                 !--- Current isotopes class name (parent tracer name)
[4046]1254
[5190]1255    !=== Isotopes children of tracer "iname": mask, names, number (same for each phase of "iname")
1256    ll = dType=='tracer' .AND. delPhase(parent) == iname .AND. phase == 'g'
1257    str = PACK(delPhase(tname), MASK = ll)                           !--- Effectively found isotopes of "iname"
1258    i%niso = SIZE(str)                                               !--- Number of "effectively found isotopes of "iname"
1259    ALLOCATE(i%keys(i%niso))
1260    FORALL(it = 1:i%niso) i%keys(it)%name = str(it)
[4046]1261
[5190]1262    !=== Geographic tagging tracers descending on tracer "iname": mask, names, number
1263    ll = dType=='tag'    .AND. delPhase(gen0N) == iname .AND. iGen == 2
1264    i%zone = PACK(strTail(tname,'_',.TRUE.), MASK = ll)              !--- Tagging zones names  for isotopes category "iname"
1265    CALL strReduce(i%zone)
1266    i%nzone = SIZE(i%zone)                                           !--- Tagging zones number for isotopes category "iname"
[4046]1267
[5190]1268    !=== Geographic tracers of the isotopes children of tracer "iname" (same for each phase of "iname")
[4046]1269    !    NOTE: One might like to create a similar variable for 2nd generation tagging tracers (tagging the gen1 tracers)
[5190]1270    str = PACK(delPhase(tname), MASK=ll)
1271    CALL strReduce(str)
1272    i%ntiso = i%niso + SIZE(str)                                     !--- Number of isotopes + their geographic tracers [ntiso]
1273    ALLOCATE(i%trac(i%ntiso))
1274    FORALL(it = 1:i%niso) i%trac(it) = i%keys(it)%name
1275    FORALL(it = i%niso+1:i%ntiso) i%trac(it) = str(it-i%niso)
[4046]1276
[5190]1277    !=== Phases for tracer "iname"
1278    i%phase = ''
1279    DO ip = 1, nphases; ph = known_phases(ip:ip); IF(strIdx(t%name,addPhase(iname, ph)) /= 0) i%phase = TRIM(i%phase)//ph; END DO
1280    i%nphas = LEN_TRIM(i%phase)                                       !--- Equal to "nqo" for water
[4046]1281
1282    !=== Tables giving the index in a table of effectively found items for each dynamical tracer (1<=iq<=nqtot)
[5190]1283    DO iq = 1, SIZE(t)
1284      t1 => tracers(iq)
1285      IF(delPhase(t1%gen0Name)/=iname .OR. t1%iGeneration==0) CYCLE  !--- Only deal with tracers descending on "iname"
1286      t1%iso_iGroup = ic                                             !--- Isotopes family       idx in list "isotopes(:)%parent"
1287      t1%iso_iName  = strIdx(i%trac, strHead(delPhase(t1%name),'_',.TRUE.)) !--- Current isotope       idx in effective isotopes list
1288      t1%iso_iZone  = strIdx(i%zone,          strTail(t1%name, '_',.TRUE.)) !--- Current isotope zone  idx in effective zones    list
1289      t1%iso_iPhase =  INDEX(i%phase,TRIM(t1%phase))                 !--- Current isotope phase idx in effective phases   list
1290      IF(t1%iGeneration /= 2) t1%iso_iZone = 0                       !--- Skip possible generation 1 tagging tracers
[4046]1291    END DO
1292
1293    !=== Table used to get iq (index in dyn array, size nqtot) from the isotope and phase indexes ; the full isotopes list
1294    !    (including tagging tracers) is sorted this way:  iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN
[5190]1295    i%iqIsoPha = RESHAPE( [( (strIdx(t%name,  addPhase(i%trac(it),i%phase(ip:ip))),       it=1, i%ntiso), ip=1, i%nphas)], &
1296                         [i%ntiso, i%nphas] )
[4984]1297    !=== Table used to get iq (index in dyn array, size nqtot) from the water and isotope and phase indexes ; the full isotopes list
1298    !    (including tagging tracers) is sorted this way:  iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN
[5190]1299    i%iqWIsoPha = RESHAPE( [( [strIdx(t%name,   addPhase('H2O',i%phase(ip:ip))), i%iqIsoPha(:,ip)], ip=1,i%nphas)], &
1300                         [1+i%ntiso, i%nphas] )
[4063]1301    !=== Table used to get ix (index in tagging tracers isotopes list, size ntiso) from the zone and isotope indexes
[5190]1302    i%itZonIso = RESHAPE( [( (strIdx(i%trac(:), TRIM(i%trac(it))//'_'//TRIM(i%zone(iz))), iz=1, i%nzone), it=1, i%niso )], &
1303                         [i%nzone, i%niso] )
[4046]1304  END DO
1305
[5190]1306  !=== READ PHYSICAL PARAMETERS FROM isoFile FILE
1307!  lerr = readIsotopesFile(isoFile, isotopes); IF(lerr) RETURN! on commente pour ne pas chercher isotopes_params.def
[4046]1308
[5001]1309  !--- GET THE isoCheck ENTRY FROM THE *.DEF FILES (MIGHT BE CHANGED TO A CLASS-DEPENDANT KEYWORD)
1310  CALL get_in('ok_iso_verif', isoCheck, .TRUE.)
1311
[4325]1312  !=== CHECK CONSISTENCY
[5001]1313  lerr = testIsotopes(); IF(lerr) RETURN
[4325]1314
[5001]1315  !=== SELECT WATER ISOTOPES CLASS OR, IF UNFOUND, THE FIRST ISOTOPES CLASS
[5618]1316  IF(.NOT.isoSelect('H2O', .TRUE.)) THEN; iH2O = ixIso; ELSE; lerr = isoSelect(1, .TRUE.); END IF
[4325]1317
1318CONTAINS
1319
1320!------------------------------------------------------------------------------------------------------------------------------
1321LOGICAL FUNCTION testIsotopes() RESULT(lerr)     !--- MAKE SURE MEMBERS OF AN ISOTOPES FAMILY ARE PRESENT IN THE SAME PHASES
1322!------------------------------------------------------------------------------------------------------------------------------
[5001]1323  INTEGER :: ix, it, ip, np, iz, nz, npha, nzon
[5190]1324  TYPE(isot_type), POINTER :: i
[4325]1325  DO ix = 1, nbIso
[5190]1326    i => isotopes(ix)
[4325]1327    !--- Check whether each isotope and tagging isotopic tracer is present in the same number of phases
[5190]1328    DO it = 1, i%ntiso; npha = i%nphas
1329      np = SUM([(COUNT(tracers(:)%name == addPhase(i%trac(it), i%phase(ip:ip))), ip=1, npha)])
[5001]1330      lerr = np /= npha
[5190]1331      CALL msg(TRIM(int2str(np))//' phases instead of '//TRIM(int2str(npha))//' for '//TRIM(i%trac(it)), modname, lerr)
[5001]1332      IF(lerr) RETURN
[4325]1333    END DO
[5190]1334    DO it = 1, i%niso; nzon = i%nzone
1335      nz = SUM([(COUNT(i%trac == TRIM(i%trac(it))//'_'//i%zone(iz)), iz=1, nzon)])
[5001]1336      lerr = nz /= nzon
[5190]1337      CALL msg(TRIM(int2str(nz))//' tagging zones instead of '//TRIM(int2str(nzon))//' for '//TRIM(i%trac(it)), modname, lerr)
[5001]1338      IF(lerr) RETURN
[4325]1339    END DO
1340  END DO
1341END FUNCTION testIsotopes
1342!------------------------------------------------------------------------------------------------------------------------------
1343
[5001]1344END FUNCTION processIsotopes
[4046]1345!==============================================================================================================================
1346
1347
1348!==============================================================================================================================
[4325]1349!=== THE ROUTINE isoSelect IS USED TO SWITCH FROM AN ISOTOPE FAMILY TO ANOTHER: ISOTOPES DEPENDENT PARAMETERS ARE UPDATED
[5190]1350!     Single generic "isoSelect" routine, using the predefined index of the parent (fast version) or its name (first call).
[4046]1351!==============================================================================================================================
[5190]1352LOGICAL FUNCTION isoSelectByName(iName, lVerbose) RESULT(lerr)
[4325]1353   IMPLICIT NONE
[5190]1354   CHARACTER(LEN=*),  INTENT(IN) :: iName
1355   LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose
[4325]1356   INTEGER :: iIso
1357   LOGICAL :: lV
[5190]1358   lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose
1359   iIso = strIdx(isotopes(:)%parent, iName)
[5001]1360   lerr = iIso == 0
1361   IF(lerr) THEN
[4325]1362      niso = 0; ntiso = 0; nzone = 0; nphas = 0; isoCheck=.FALSE.
[5190]1363      CALL msg('no isotope family named "'//TRIM(iName)//'"', ll=lV)
[4325]1364      RETURN
1365   END IF
[5190]1366   lerr = isoSelectByIndex(iIso, lV)
[4325]1367END FUNCTION isoSelectByName
1368!==============================================================================================================================
[5190]1369LOGICAL FUNCTION isoSelectByIndex(iIso, lVerbose) RESULT(lerr)
[4325]1370   IMPLICIT NONE
[5190]1371   INTEGER,           INTENT(IN) :: iIso
1372   LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose
[4325]1373   LOGICAL :: lV
[5190]1374   lv = .FALSE.; IF(PRESENT(lVerbose)) lv = lVerbose
[4325]1375   lerr = .FALSE.
1376   IF(iIso == ixIso) RETURN                                          !--- Nothing to do if the index is already OK
[5190]1377   lerr = iIso<=0 .OR. iIso>SIZE(isotopes)
[4325]1378   CALL msg('Inconsistent isotopes family index '//TRIM(int2str(iIso))//': should be > 0 and <= '&
[5190]1379          //TRIM(int2str(SIZE(isotopes)))//'"', ll = lerr .AND. lV)
[4325]1380   IF(lerr) RETURN
1381   ixIso = iIso                                                      !--- Update currently selected family index
[5190]1382   isotope  => isotopes(ixIso)                                       !--- Select corresponding component
[4325]1383   isoKeys  => isotope%keys;     niso     = isotope%niso
1384   isoName  => isotope%trac;     ntiso    = isotope%ntiso
1385   isoZone  => isotope%zone;     nzone    = isotope%nzone
1386   isoPhas  => isotope%phase;    nphas    = isotope%nphas
1387   itZonIso => isotope%itZonIso; isoCheck = isotope%check
1388   iqIsoPha => isotope%iqIsoPha
[5190]1389   iqWIsoPha => isotope%iqWIsoPha
[4325]1390END FUNCTION isoSelectByIndex
1391!==============================================================================================================================
[4046]1392
1393
1394!==============================================================================================================================
[4301]1395!=== ADD THE <key>=<val> PAIR TO THE "ky[(:)]" KEY[S] DESCRIPTOR[S] OR THE <key>=<val(:)> PAIRS TO THE "ky(:)" KEYS DESCRIPTORS
1396!==============================================================================================================================
[4987]1397SUBROUTINE addKey_s11(key, sval, ky, lOverWrite)
1398  CHARACTER(LEN=*),  INTENT(IN)    :: key, sval
[4046]1399  TYPE(keys_type),   INTENT(INOUT) :: ky
1400  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
[4301]1401!------------------------------------------------------------------------------------------------------------------------------
[4046]1402  CHARACTER(LEN=maxlen), ALLOCATABLE :: k(:), v(:)
1403  INTEGER :: iky, nky
1404  LOGICAL :: lo
[4325]1405  lo=.TRUE.; IF(PRESENT(lOverWrite)) lo=lOverWrite
[4348]1406  IF(.NOT.ALLOCATED(ky%key)) THEN
1407    ALLOCATE(ky%key(1)); ky%key(1)=key
[4987]1408    ALLOCATE(ky%val(1)); ky%val(1)=sval
[4348]1409    RETURN
1410  END IF
[4367]1411  iky = strIdx(ky%key,key)
[4046]1412  IF(iky == 0) THEN
[4367]1413    nky = SIZE(ky%key)
[4987]1414    ALLOCATE(k(nky+1)); k(1:nky) = ky%key; k(nky+1) = key;  ky%key = k
1415    ALLOCATE(v(nky+1)); v(1:nky) = ky%val; v(nky+1) = sval; ky%val = v
[4325]1416  ELSE IF(lo) THEN
[4987]1417    ky%key(iky) = key; ky%val(iky) = sval
[4046]1418  END IF
[4987]1419END SUBROUTINE addKey_s11
[4046]1420!==============================================================================================================================
[4987]1421SUBROUTINE addKey_i11(key, ival, ky, lOverWrite)
1422  CHARACTER(LEN=*),  INTENT(IN)    :: key
1423  INTEGER,           INTENT(IN)    :: ival
1424  TYPE(keys_type),   INTENT(INOUT) :: ky
1425  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
1426!------------------------------------------------------------------------------------------------------------------------------
1427  CALL addKey_s11(key, int2str(ival), ky, lOverWrite)
1428END SUBROUTINE addKey_i11
1429!==============================================================================================================================
1430SUBROUTINE addKey_r11(key, rval, ky, lOverWrite)
1431  CHARACTER(LEN=*),  INTENT(IN)    :: key
1432  REAL,              INTENT(IN)    :: rval
1433  TYPE(keys_type),   INTENT(INOUT) :: ky
1434  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
1435!------------------------------------------------------------------------------------------------------------------------------
1436  CALL addKey_s11(key, real2str(rval), ky, lOverWrite)
1437END SUBROUTINE addKey_r11
1438!==============================================================================================================================
1439SUBROUTINE addKey_l11(key, lval, ky, lOverWrite)
1440  CHARACTER(LEN=*),  INTENT(IN)    :: key
1441  LOGICAL,           INTENT(IN)    :: lval
1442  TYPE(keys_type),   INTENT(INOUT) :: ky
1443  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
1444!------------------------------------------------------------------------------------------------------------------------------
1445  CALL addKey_s11(key, bool2str(lval), ky, lOverWrite)
1446END SUBROUTINE addKey_l11
1447!==============================================================================================================================
1448!==============================================================================================================================
1449SUBROUTINE addKey_s1m(key, sval, ky, lOverWrite)
1450  CHARACTER(LEN=*),  INTENT(IN)    :: key, sval
[4046]1451  TYPE(keys_type),   INTENT(INOUT) :: ky(:)
1452  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
[4301]1453!------------------------------------------------------------------------------------------------------------------------------
[4046]1454  INTEGER :: itr
[5001]1455  DO itr = 1, SIZE(ky); CALL addKey_s11(key, sval, ky(itr), lOverWrite); END DO
[4987]1456END SUBROUTINE addKey_s1m
[4046]1457!==============================================================================================================================
[4987]1458SUBROUTINE addKey_i1m(key, ival, ky, lOverWrite)
1459  CHARACTER(LEN=*),  INTENT(IN)    :: key
1460  INTEGER,           INTENT(IN)    :: ival
[4325]1461  TYPE(keys_type),   INTENT(INOUT) :: ky(:)
1462  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
1463!------------------------------------------------------------------------------------------------------------------------------
1464  INTEGER :: itr
[5001]1465  DO itr = 1, SIZE(ky); CALL addKey_s11(key, int2str(ival), ky(itr), lOverWrite); END DO
[4987]1466END SUBROUTINE addKey_i1m
[4325]1467!==============================================================================================================================
[4987]1468SUBROUTINE addKey_r1m(key, rval, ky, lOverWrite)
1469  CHARACTER(LEN=*),  INTENT(IN)    :: key
1470  REAL,              INTENT(IN)    :: rval
1471  TYPE(keys_type),   INTENT(INOUT) :: ky(:)
1472  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
1473!------------------------------------------------------------------------------------------------------------------------------
1474  INTEGER :: itr
[5001]1475  DO itr = 1, SIZE(ky); CALL addKey_s11(key, real2str(rval), ky(itr), lOverWrite); END DO
[4987]1476END SUBROUTINE addKey_r1m
1477!==============================================================================================================================
1478SUBROUTINE addKey_l1m(key, lval, ky, lOverWrite)
1479  CHARACTER(LEN=*),  INTENT(IN)    :: key
1480  LOGICAL,           INTENT(IN)    :: lval
1481  TYPE(keys_type),   INTENT(INOUT) :: ky(:)
1482  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
1483!------------------------------------------------------------------------------------------------------------------------------
1484  INTEGER :: itr
[5001]1485  DO itr = 1, SIZE(ky); CALL addKey_s11(key, bool2str(lval), ky(itr), lOverWrite); END DO
[4987]1486END SUBROUTINE addKey_l1m
1487!==============================================================================================================================
1488!==============================================================================================================================
1489SUBROUTINE addKey_smm(key, sval, ky, lOverWrite)
1490  CHARACTER(LEN=*),  INTENT(IN)    :: key, sval(:)
1491  TYPE(keys_type),   INTENT(INOUT) :: ky(:)
1492  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
1493!------------------------------------------------------------------------------------------------------------------------------
1494  INTEGER :: itr
1495  DO itr = 1, SIZE(ky); CALL addKey_s11(key, sval(itr), ky(itr), lOverWrite); END DO
1496END SUBROUTINE addKey_smm
1497!==============================================================================================================================
1498SUBROUTINE addKey_imm(key, ival, ky, lOverWrite)
1499  CHARACTER(LEN=*),  INTENT(IN)    :: key
1500  INTEGER,           INTENT(IN)    :: ival(:)
1501  TYPE(keys_type),   INTENT(INOUT) :: ky(:)
1502  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
1503!------------------------------------------------------------------------------------------------------------------------------
1504  INTEGER :: itr
1505  DO itr = 1, SIZE(ky); CALL addKey_s11(key, int2str(ival(itr)), ky(itr), lOverWrite); END DO
1506END SUBROUTINE addKey_imm
1507!==============================================================================================================================
1508SUBROUTINE addKey_rmm(key, rval, ky, lOverWrite)
1509  CHARACTER(LEN=*),  INTENT(IN)    :: key
1510  REAL,              INTENT(IN)    :: rval(:)
1511  TYPE(keys_type),   INTENT(INOUT) :: ky(:)
1512  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
1513!------------------------------------------------------------------------------------------------------------------------------
1514  INTEGER :: itr
1515  DO itr = 1, SIZE(ky); CALL addKey_s11(key, real2str(rval(itr)), ky(itr), lOverWrite); END DO
1516END SUBROUTINE addKey_rmm
1517!==============================================================================================================================
1518SUBROUTINE addKey_lmm(key, lval, ky, lOverWrite)
1519  CHARACTER(LEN=*),  INTENT(IN)    :: key
1520  LOGICAL,           INTENT(IN)    :: lval(:)
1521  TYPE(keys_type),   INTENT(INOUT) :: ky(:)
1522  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
1523!------------------------------------------------------------------------------------------------------------------------------
1524  INTEGER :: itr
1525  DO itr = 1, SIZE(ky); CALL addKey_s11(key, bool2str(lval(itr)), ky(itr), lOverWrite); END DO
1526END SUBROUTINE addKey_lmm
1527!==============================================================================================================================
[4301]1528
1529
1530!==============================================================================================================================
1531!=== OVERWRITE THE KEYS OF THE TRACER NAMED "tr0" WITH THE VALUES FOUND IN THE *.def FILES, IF ANY. ===========================
1532!==============================================================================================================================
[5190]1533SUBROUTINE addKeysFromDef(t, tr0)
1534  TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: t(:)
[4046]1535  CHARACTER(LEN=*),             INTENT(IN)    :: tr0
[4301]1536!------------------------------------------------------------------------------------------------------------------------------
[4046]1537  CHARACTER(LEN=maxlen) :: val
1538  INTEGER               :: ik, jd
[5190]1539  jd = strIdx(t%name, tr0)
[4046]1540  IF(jd == 0) RETURN
[5190]1541  DO ik = 1, SIZE(t(jd)%keys%key)
1542    CALL get_in(t(jd)%keys%key(ik), val, '*none*')
1543    IF(val /= '*none*') CALL addKey(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.)
[4046]1544  END DO
[5190]1545END SUBROUTINE addKeysFromDef
[4046]1546!==============================================================================================================================
[4301]1547
1548
1549!==============================================================================================================================
1550!=== REMOVE THE KEYS NAMED "keyn(:)" FROM EITHER THE "itr"th OR ALL THE KEYS DESCRIPTORS OF "ky(:)" ===========================
1551!==============================================================================================================================
[4046]1552SUBROUTINE delKey_1(itr, keyn, ky)
1553  INTEGER,          INTENT(IN)    :: itr
1554  CHARACTER(LEN=*), INTENT(IN)    :: keyn(:)
[5190]1555  TYPE(trac_type),  INTENT(INOUT) :: ky(:)
[4301]1556!------------------------------------------------------------------------------------------------------------------------------
[4046]1557  CHARACTER(LEN=maxlen), ALLOCATABLE :: k(:), v(:)
1558  LOGICAL,               ALLOCATABLE :: ll(:)
1559  INTEGER :: iky
1560  IF(itr<=0 .OR. itr>SIZE(ky, DIM=1)) RETURN                          !--- Index is out of range
[5190]1561  ll = [( ALL(keyn/=ky(itr)%keys%key(iky)), iky=1, SIZE(ky(itr)%keys%key) )]
1562  k = PACK(ky(itr)%keys%key, MASK=ll); CALL MOVE_ALLOC(FROM=k, TO=ky(itr)%keys%key)
1563  v = PACK(ky(itr)%keys%val, MASK=ll); CALL MOVE_ALLOC(FROM=v, TO=ky(itr)%keys%val)
[4046]1564END SUBROUTINE delKey_1
1565!==============================================================================================================================
1566SUBROUTINE delKey(keyn, ky)
1567  CHARACTER(LEN=*), INTENT(IN)    :: keyn(:)
[5190]1568  TYPE(trac_type),  INTENT(INOUT) :: ky(:)
[4301]1569!------------------------------------------------------------------------------------------------------------------------------
[4046]1570  INTEGER :: iky
1571  DO iky = 1, SIZE(ky); CALL delKey_1(iky, keyn, ky); END DO
1572END SUBROUTINE delKey
1573!==============================================================================================================================
1574
1575
1576!==============================================================================================================================
[5001]1577!===   INTERNAL FUNCTION: GET THE VALUE OF A KEY FOR "itr"th TRACER FROM A "keys_type" DERIVED TYPE AND RETURN THE RESULT   ===
1578!===   IF keyn CONTAINS SEVERAL ELEMENTS, TRY WITH EACH ELEMENT ONE AFTER THE OTHER                                         ===
[4301]1579!==============================================================================================================================
[5001]1580CHARACTER(LEN=maxlen) FUNCTION fgetKeyIdx(itr, keyn, ky, lerr) RESULT(val)
[4325]1581  INTEGER,                    INTENT(IN)  :: itr
[5001]1582  CHARACTER(LEN=*),           INTENT(IN)  :: keyn(:)
[4325]1583  TYPE(keys_type),            INTENT(IN)  :: ky(:)
1584  LOGICAL,          OPTIONAL, INTENT(OUT) :: lerr
[4046]1585!------------------------------------------------------------------------------------------------------------------------------
[5001]1586  INTEGER :: ik
[4325]1587  LOGICAL :: ler
[5001]1588  ler = .TRUE.
1589  DO ik = 1, SIZE(keyn)
1590    CALL getKeyIdx(keyn(ik)); IF(.NOT.ler) EXIT
1591  END DO
[4325]1592  IF(PRESENT(lerr)) lerr = ler
[5001]1593
1594CONTAINS
1595
1596SUBROUTINE getKeyIdx(keyn)
1597  CHARACTER(LEN=*), INTENT(IN) :: keyn
[4120]1598!------------------------------------------------------------------------------------------------------------------------------
[5001]1599  INTEGER :: iky
1600  iky = 0; val = ''
1601  ler = itr <= 0 .OR. itr > SIZE(ky); IF(ler) RETURN
1602  iky = strIdx(ky(itr)%key(:), keyn)
1603  ler = iky == 0;                     IF(ler) RETURN
1604  val = ky(itr)%val(iky)
1605END SUBROUTINE getKeyIdx
1606
1607END FUNCTION fgetKeyIdx
[4120]1608!==============================================================================================================================
[4301]1609
1610
1611!==============================================================================================================================
[5001]1612!===                                          GET KEYS VALUES FROM TRACERS INDICES                                          ===
[4301]1613!==============================================================================================================================
[5001]1614!=== TRY TO GET THE KEY NAMED "key" FOR THE "itr"th TRACER IN:                                                              ===
1615!===  * ARGUMENT "ky" DATABASE IF SPECIFIED ; OTHERWISE:                                                                    ===
[5190]1616!===  * IN INTERNAL TRACERS DATABASE "tracers(:)%keys" (IF UNFOUND, IN INTERNAL ISOTOPES DATABASE "isotope%keys(:)")        ===
[5001]1617!=== THE RETURNED VALUE (STRING, AN INTEGER, A REAL OR A LOGICAL) CAN BE EITHER:                                            ===
1618!===  * A SCALAR                                                                                                            ===
1619!===  * A VECTOR, WHICH IS THE FOUND VALUE PARSED WITH THE SEPARATOR ","                                                    ===
1620!===                                                                                                                        ===
1621!=== SYNTAX:       lerr = getKeyByIndex_{sirl}{1m}{1m}1(keyn[(:)], val[(:)], itr[, ky(:)]          [, def][, lDisp])        ===
1622!==============================================================================================================================
1623!=== IF "itr" IS NOT PRESENT, VALUES FOR ALL THE TRACERS OF THE SELECTED DATABASE ARE STORED IN THE VECTOR "val(:)"         ===
1624!=== THE NAME OF THE TRACERS FOUND IN THE EFFECTIVELY USED DATABASE CAN BE RETURNED OPTIONALLY IN "nam(:)"                  ===
1625!=== SYNTAX        lerr = getKeyByIndex_{sirl}{1m}mm   (keyn[(:)], val (:)      [, ky(:)][, nam(:)][, def][, lDisp])        ===
1626!==============================================================================================================================
1627LOGICAL FUNCTION getKeyByIndex_s111(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
[4046]1628  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
1629  CHARACTER(LEN=maxlen),     INTENT(OUT) :: val
[5001]1630  INTEGER,                   INTENT(IN)  :: itr
[4046]1631  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
[5001]1632  CHARACTER(LEN=*),OPTIONAL, INTENT(IN)  :: def
1633  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
1634  lerr = getKeyByIndex_sm11([keyn], val, itr, ky, def, lDisp)
1635END FUNCTION getKeyByIndex_s111
1636!==============================================================================================================================
1637LOGICAL FUNCTION getKeyByIndex_i111(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
1638  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
1639  INTEGER,                   INTENT(OUT) :: val
1640  INTEGER,                   INTENT(IN)  :: itr
1641  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
1642  INTEGER,         OPTIONAL, INTENT(IN)  :: def
1643  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
1644  lerr = getKeyByIndex_im11([keyn], val, itr, ky, def, lDisp)
1645END FUNCTION getKeyByIndex_i111
1646!==============================================================================================================================
1647LOGICAL FUNCTION getKeyByIndex_r111(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
1648  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
1649  REAL   ,                   INTENT(OUT) :: val
1650  INTEGER,                   INTENT(IN)  :: itr
1651  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
1652  REAL,            OPTIONAL, INTENT(IN)  :: def
1653  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
1654  lerr = getKeyByIndex_rm11([keyn], val, itr, ky, def, lDisp)
1655END FUNCTION getKeyByIndex_r111
1656!==============================================================================================================================
1657LOGICAL FUNCTION getKeyByIndex_l111(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
1658  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
1659  LOGICAL,                   INTENT(OUT) :: val
1660  INTEGER,                   INTENT(IN)  :: itr
1661  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
1662  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
1663  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
1664  lerr = getKeyByIndex_lm11([keyn], val, itr, ky, def, lDisp)
1665END FUNCTION getKeyByIndex_l111
1666!==============================================================================================================================
1667!==============================================================================================================================
1668LOGICAL FUNCTION getKeyByIndex_sm11(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
1669  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:)
1670  CHARACTER(LEN=maxlen),     INTENT(OUT) :: val
1671  INTEGER,                   INTENT(IN)  :: itr
1672  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
1673  CHARACTER(LEN=*),OPTIONAL, INTENT(IN)  :: def
1674  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
[4301]1675!------------------------------------------------------------------------------------------------------------------------------
[5001]1676  CHARACTER(LEN=maxlen) :: s
1677  LOGICAL :: lD
1678  lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp
1679  s = 'key "'//TRIM(strStack(keyn, '/'))//'" for tracer nr. '//TRIM(int2str(itr))
1680  lerr = .TRUE.
1681  IF(lerr .AND. PRESENT(ky))         val = fgetKey(ky)                                   !--- "ky"
[5190]1682  IF(lerr .AND. ALLOCATED (tracers)) val = fgetKey(tracers(:)%keys)                      !--- "tracers"
[5001]1683  IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:))                      !--- "isotope"
1684  IF(lerr .AND. PRESENT(def)) THEN
1685     val = def; lerr = .NOT.PRESENT(def)
1686     CALL msg('Using defaut value of '//TRIM(s)//': '//TRIM(def), modname, lD)
[4046]1687  END IF
[5001]1688  CALL msg('No '//TRIM(s)//' or out of bounds index', modname, lD .AND. lerr)
1689
1690CONTAINS
1691
1692CHARACTER(LEN=maxlen) FUNCTION fgetKey(ky) RESULT(val)
1693  TYPE(keys_type),  INTENT(IN)  :: ky(:)
1694  lerr = SIZE(ky) == 0; IF(lerr) RETURN
1695  val = fgetKeyIdx(itr, keyn(:), ky, lerr)
1696END FUNCTION fgetKey
1697
1698END FUNCTION getKeyByIndex_sm11
[4046]1699!==============================================================================================================================
[5001]1700LOGICAL FUNCTION getKeyByIndex_im11(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
1701  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:)
1702  INTEGER,                   INTENT(OUT) :: val
1703  INTEGER,                   INTENT(IN)  :: itr
1704  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
1705  INTEGER,         OPTIONAL, INTENT(IN)  :: def
1706  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
1707!------------------------------------------------------------------------------------------------------------------------------
1708  CHARACTER(LEN=maxlen) :: sval, s
1709  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, int2str(def), lDisp)
1710  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp)
1711  IF(lerr) RETURN
1712  val = str2int(sval)
1713  lerr = val == -HUGE(1)
1714  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
1715  CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr)
1716END FUNCTION getKeyByIndex_im11
1717!==============================================================================================================================
1718LOGICAL FUNCTION getKeyByIndex_rm11(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
1719  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:)
1720  REAL   ,                   INTENT(OUT) :: val
1721  INTEGER,                   INTENT(IN)  :: itr
1722  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
1723  REAL,            OPTIONAL, INTENT(IN)  :: def
1724  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
1725!------------------------------------------------------------------------------------------------------------------------------
1726  CHARACTER(LEN=maxlen) :: sval, s
1727  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, real2str(def), lDisp)
1728  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp)
1729  IF(lerr) RETURN
1730  val = str2real(sval)
1731  lerr = val == -HUGE(1.)
1732  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
1733  CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr)
1734END FUNCTION getKeyByIndex_rm11
1735!==============================================================================================================================
1736LOGICAL FUNCTION getKeyByIndex_lm11(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
1737  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:)
1738  LOGICAL,                   INTENT(OUT) :: val
1739  INTEGER,                   INTENT(IN)  :: itr
1740  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
1741  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
1742  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
1743!------------------------------------------------------------------------------------------------------------------------------
1744  CHARACTER(LEN=maxlen) :: sval, s
1745  INTEGER               :: ival
1746  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, bool2str(def), lDisp)
1747  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp)
1748  IF(lerr) RETURN
1749  ival = str2bool(sval)
1750  lerr = ival == -1
1751  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
1752  CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr)
1753  IF(.NOT.lerr) val = ival == 1
1754END FUNCTION getKeyByIndex_lm11
1755!==============================================================================================================================
1756!==============================================================================================================================
1757LOGICAL FUNCTION getKeyByIndex_s1m1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
[4328]1758  CHARACTER(LEN=*),                   INTENT(IN)  :: keyn
1759  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
[5001]1760  INTEGER,                            INTENT(IN)  :: itr
[4328]1761  TYPE(keys_type),          OPTIONAL, INTENT(IN)  :: ky(:)
[5001]1762  CHARACTER(LEN=*),         OPTIONAL, INTENT(IN)  :: def
1763  LOGICAL,                  OPTIONAL, INTENT(IN)  :: lDisp
[4328]1764!------------------------------------------------------------------------------------------------------------------------------
[5001]1765  CHARACTER(LEN=maxlen)              :: sval
1766  lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, def, lDisp); IF(lerr) RETURN
[4328]1767  lerr = strParse(sval, ',', val)
[5001]1768  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
1769END FUNCTION getKeyByIndex_s1m1
[4328]1770!==============================================================================================================================
[5001]1771LOGICAL FUNCTION getKeyByIndex_i1m1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
1772  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
1773  INTEGER,      ALLOCATABLE, INTENT(OUT) :: val(:)
1774  INTEGER,                   INTENT(IN)  :: itr
1775  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
1776  INTEGER,         OPTIONAL, INTENT(IN)  :: def
1777  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
1778!------------------------------------------------------------------------------------------------------------------------------
1779  CHARACTER(LEN=maxlen)              :: sval, s
1780  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
1781  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, int2str(def), lDisp)
1782  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, lDisp=lDisp)
1783  IF(lerr) RETURN
1784  lerr = strParse(sval, ',', svals)
1785  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
1786  val = str2int(svals)
[5190]1787  lerr = ANY(val == -HUGE(1))
[5001]1788  s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
1789  CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr)
1790END FUNCTION getKeyByIndex_i1m1
1791!==============================================================================================================================
1792LOGICAL FUNCTION getKeyByIndex_r1m1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
1793  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
1794  REAL,         ALLOCATABLE, INTENT(OUT) :: val(:)
1795  INTEGER,                   INTENT(IN)  :: itr
1796  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
1797  REAL,            OPTIONAL, INTENT(IN)  :: def
1798  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
1799!------------------------------------------------------------------------------------------------------------------------------
1800  CHARACTER(LEN=maxlen)              :: sval, s
1801  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
1802  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, real2str(def), lDisp)
1803  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, lDisp=lDisp)
1804  lerr = strParse(sval, ',', svals)
1805  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
1806  val = str2real(svals)
[5190]1807  lerr = ANY(val == -HUGE(1.))
[5001]1808  s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
1809  CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr)
1810END FUNCTION getKeyByIndex_r1m1
1811!==============================================================================================================================
1812LOGICAL FUNCTION getKeyByIndex_l1m1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
1813  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
1814  LOGICAL,      ALLOCATABLE, INTENT(OUT) :: val(:)
1815  INTEGER,                   INTENT(IN)  :: itr
1816  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
1817  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
1818  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
1819!------------------------------------------------------------------------------------------------------------------------------
1820  CHARACTER(LEN=maxlen)              :: sval, s
1821  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
1822  INTEGER,               ALLOCATABLE :: ivals(:)
1823  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, bool2str(def), lDisp)
1824  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, lDisp=lDisp)
1825  lerr = strParse(sval, ',', svals)
1826  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
1827  ivals = str2bool(svals)
[5190]1828  lerr = ANY(ivals == -1)
[5001]1829  s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
1830  CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr)
1831  IF(.NOT.lerr) val = ivals == 1
1832END FUNCTION getKeyByIndex_l1m1
1833!==============================================================================================================================
1834!==============================================================================================================================
1835LOGICAL FUNCTION getKeyByIndex_smm1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
1836  CHARACTER(LEN=*),                   INTENT(IN)  :: keyn(:)
1837  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
1838  INTEGER,                            INTENT(IN)  :: itr
1839  TYPE(keys_type),          OPTIONAL, INTENT(IN)  :: ky(:)
1840  CHARACTER(LEN=*),         OPTIONAL, INTENT(IN)  :: def
1841  LOGICAL,                  OPTIONAL, INTENT(IN)  :: lDisp
1842!------------------------------------------------------------------------------------------------------------------------------
[5003]1843  CHARACTER(LEN=maxlen) :: sval
[5001]1844  lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, def, lDisp); IF(lerr) RETURN
1845  lerr = strParse(sval, ',', val)
1846  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
1847END FUNCTION getKeyByIndex_smm1
1848!==============================================================================================================================
1849LOGICAL FUNCTION getKeyByIndex_imm1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
1850  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:)
1851  INTEGER,      ALLOCATABLE, INTENT(OUT) :: val(:)
1852  INTEGER,                   INTENT(IN)  :: itr
1853  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
1854  INTEGER,         OPTIONAL, INTENT(IN)  :: def
1855  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
1856!------------------------------------------------------------------------------------------------------------------------------
1857  CHARACTER(LEN=maxlen)              :: sval, s
1858  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
1859  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, int2str(def), lDisp)
1860  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp)
1861  IF(lerr) RETURN
1862  lerr = strParse(sval, ',', svals)
1863  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
1864  val = str2int(svals)
[5190]1865  lerr = ANY(val == -HUGE(1))
[5001]1866  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
1867  CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr)
1868END FUNCTION getKeyByIndex_imm1
1869!==============================================================================================================================
1870LOGICAL FUNCTION getKeyByIndex_rmm1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
1871  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:)
1872  REAL,         ALLOCATABLE, INTENT(OUT) :: val(:)
1873  INTEGER,                   INTENT(IN)  :: itr
1874  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
1875  REAL,            OPTIONAL, INTENT(IN)  :: def
1876  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
1877!------------------------------------------------------------------------------------------------------------------------------
1878  CHARACTER(LEN=maxlen)              :: sval, s
1879  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
1880  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, real2str(def), lDisp)
1881  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp)
1882  IF(lerr) RETURN
1883  lerr = strParse(sval, ',', svals)
1884  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
1885  val = str2real(svals)
[5190]1886  lerr = ANY(val == -HUGE(1.))
[5001]1887  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
1888  CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr)
1889END FUNCTION getKeyByIndex_rmm1
1890!==============================================================================================================================
1891LOGICAL FUNCTION getKeyByIndex_lmm1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
1892  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:)
1893  LOGICAL,      ALLOCATABLE, INTENT(OUT) :: val(:)
1894  INTEGER,                   INTENT(IN)  :: itr
1895  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
1896  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
1897  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
1898!------------------------------------------------------------------------------------------------------------------------------
1899  CHARACTER(LEN=maxlen)              :: sval, s
1900  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
1901  INTEGER,               ALLOCATABLE :: ivals(:)
1902  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, bool2str(def), lDisp)
1903  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp)
1904  IF(lerr) RETURN
1905  lerr = strParse(sval, ',', svals)
1906  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
1907  ivals = str2bool(svals)
[5190]1908  lerr = ANY(ivals == -1)
[5001]1909  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
1910  CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr)
1911  IF(.NOT.lerr) val = ivals == 1
1912END FUNCTION getKeyByIndex_lmm1
1913!==============================================================================================================================
1914!==============================================================================================================================
[5190]1915LOGICAL FUNCTION getKeyByIndex_s1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
1916  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn
1917  CHARACTER(LEN=maxlen),           ALLOCATABLE, INTENT(OUT) :: val(:)
1918  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::  ky(:)
1919  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1920  CHARACTER(LEN=*),      OPTIONAL,              INTENT(IN)  :: def
1921  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
1922  lerr = getKeyByIndex_smmm([keyn], val, ky, nam, def, lDisp)
[5001]1923END FUNCTION getKeyByIndex_s1mm
1924!==============================================================================================================================
[5190]1925LOGICAL FUNCTION getKeyByIndex_i1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
1926  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn
1927  INTEGER,                         ALLOCATABLE, INTENT(OUT) :: val(:)
1928  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::  ky(:)
1929  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1930  INTEGER,               OPTIONAL,              INTENT(IN)  :: def
1931  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
1932  lerr = getKeyByIndex_immm([keyn], val, ky, nam, def, lDisp)
[5001]1933END FUNCTION getKeyByIndex_i1mm
1934!==============================================================================================================================
[5190]1935LOGICAL FUNCTION getKeyByIndex_r1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
1936  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn
1937  REAL,                            ALLOCATABLE, INTENT(OUT) :: val(:)
1938  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::  ky(:)
1939  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1940  REAL,                  OPTIONAL,              INTENT(IN)  :: def
1941  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
1942  lerr = getKeyByIndex_rmmm([keyn], val, ky, nam, def, lDisp)
[5001]1943END FUNCTION getKeyByIndex_r1mm
1944!==============================================================================================================================
[5190]1945LOGICAL FUNCTION getKeyByIndex_l1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
1946  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn
1947  LOGICAL,                         ALLOCATABLE, INTENT(OUT) :: val(:)
1948  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::  ky(:)
1949  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
1950  LOGICAL,               OPTIONAL,              INTENT(IN)  :: def
1951  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
1952  lerr = getKeyByIndex_lmmm([keyn], val, ky, nam, def, lDisp)
[5001]1953END FUNCTION getKeyByIndex_l1mm
1954!==============================================================================================================================
1955!==============================================================================================================================
[5190]1956LOGICAL FUNCTION getKeyByIndex_smmm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
1957  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn(:)
1958  CHARACTER(LEN=maxlen),           ALLOCATABLE, INTENT(OUT) ::  val(:)
1959  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::   ky(:)
1960  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) ::  nam(:)
1961  CHARACTER(LEN=*),      OPTIONAL,              INTENT(IN)  ::  def
1962  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
[4301]1963!------------------------------------------------------------------------------------------------------------------------------
[5001]1964  CHARACTER(LEN=maxlen) :: s
[5190]1965  CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:)
[5001]1966  INTEGER :: iq, nq(3), k
1967  LOGICAL :: lD, l(3)
1968  lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp
1969  s = 'key "'//TRIM(strStack(keyn, '/'))//'"'
1970  lerr = .TRUE.
1971  IF(PRESENT(ky)) THEN;                 val = fgetKey(ky)                                !--- "ky"
[5190]1972  ELSE IF(ALLOCATED(tracers)) THEN;     val = fgetKey(tracers(:)%keys)                   !--- "tracers"
[5001]1973     IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:))                   !--- "isotope"
1974  END IF
[5190]1975  IF(.NOT.lerr) THEN; IF(PRESENT(nam)) nam = tname; RETURN; END IF
[5001]1976  IF(.NOT.PRESENT(def)) THEN; CALL msg('No '//TRIM(s)//' found', modname, lD); RETURN; END IF
[4325]1977
[5001]1978  !--- DEFAULT VALUE
1979  l = [PRESENT(ky), ALLOCATED(tracers), ASSOCIATED(isotope)]; nq(:) = 0
1980  IF(l(1)) nq(1) = SIZE(ky)
1981  IF(l(2)) nq(2) = SIZE(tracers)
1982  IF(l(3)) nq(3) = SIZE(isotope%keys)
1983  DO k = 1, 3; IF(l(k) .AND. nq(k) /= 0) THEN; val = [(def, iq = 1, nq(k))]; EXIT; END IF; END DO
1984  lerr = k == 4
1985  CALL msg('Using defaut value for '//TRIM(s)//': '//TRIM(def), modname, lD .AND. .NOT.lerr)
1986  CALL msg('No '//TRIM(s), modname, lD .AND. lerr)
[4325]1987
[5001]1988CONTAINS
[4325]1989
[5001]1990FUNCTION fgetKey(ky) RESULT(val)
1991  CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:)
1992  TYPE(keys_type),       INTENT(IN)  :: ky(:)
1993  LOGICAL :: ler(SIZE(ky))
1994  INTEGER :: iq
1995  lerr = SIZE(ky) == 0; IF(lerr) RETURN
[5190]1996  tname = ky%name
[5001]1997  val = [(fgetKeyIdx(iq, keyn(:), ky, ler(iq)), iq = 1, SIZE(ky))]
1998  lerr = ANY(ler)
1999END FUNCTION fgetKey
[4325]2000
[5001]2001END FUNCTION getKeyByIndex_smmm
[4046]2002!==============================================================================================================================
[5190]2003LOGICAL FUNCTION getKeyByIndex_immm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
2004  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn(:)
2005  INTEGER,                         ALLOCATABLE, INTENT(OUT) ::  val(:)
2006  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::   ky(:)
2007  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) ::  nam(:)
2008  INTEGER,               OPTIONAL,              INTENT(IN)  ::  def
2009  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
[4325]2010!------------------------------------------------------------------------------------------------------------------------------
[5001]2011  CHARACTER(LEN=maxlen) :: s
2012  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:), tname(:)
2013  LOGICAL,               ALLOCATABLE ::    ll(:)
[5190]2014  IF(     PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, int2str(def), lDisp)
2015  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, lDisp=lDisp)
[5001]2016  IF(lerr) RETURN
2017  val = str2int(svals)
[5190]2018  ll = val == -HUGE(1)
2019  lerr = ANY(ll); IF(.NOT.lerr) THEN; IF(PRESENT(nam)) nam = tname; RETURN; END IF
[5001]2020  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(PACK(tname, MASK=ll)))//' is not'
2021  CALL msg(TRIM(s)//' an integer: '//TRIM(strStack(svals, MASK=ll)), modname, lerr)
[5190]2022  IF(.NOT.lerr .AND. PRESENT(nam)) nam = tname
[5001]2023END FUNCTION getKeyByIndex_immm
2024!==============================================================================================================================
[5190]2025LOGICAL FUNCTION getKeyByIndex_rmmm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
2026  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn(:)
2027  REAL,                            ALLOCATABLE, INTENT(OUT) ::  val(:)
2028  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::   ky(:)
2029  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) ::  nam(:)
2030  REAL,                  OPTIONAL,              INTENT(IN)  ::  def
2031  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
[5001]2032!------------------------------------------------------------------------------------------------------------------------------
2033  CHARACTER(LEN=maxlen) :: s
2034  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:), tname(:)
2035  LOGICAL,               ALLOCATABLE ::    ll(:)
[5190]2036  IF(     PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, real2str(def), lDisp)
2037  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, lDisp=lDisp)
[5001]2038  IF(lerr) RETURN
2039  val = str2real(svals)
[5190]2040  ll = val == -HUGE(1.)
2041  lerr = ANY(ll); IF(.NOT.lerr) THEN; IF(PRESENT(nam)) nam = tname; RETURN; END IF
[5001]2042  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(PACK(tname, MASK=ll)))//' is not a'
2043  CALL msg(TRIM(s)//' a real: '//TRIM(strStack(svals, MASK=ll)), modname)
2044END FUNCTION getKeyByIndex_rmmm
2045!==============================================================================================================================
[5190]2046LOGICAL FUNCTION getKeyByIndex_lmmm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
2047  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn(:)
2048  LOGICAL,                         ALLOCATABLE, INTENT(OUT) ::  val(:)
2049  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::   ky(:)
2050  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) ::  nam(:)
2051  LOGICAL,               OPTIONAL,              INTENT(IN)  ::  def
2052  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
[5001]2053!------------------------------------------------------------------------------------------------------------------------------
2054  CHARACTER(LEN=maxlen) :: s
2055  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:), tname(:)
2056  LOGICAL,               ALLOCATABLE ::    ll(:)
2057  INTEGER,               ALLOCATABLE :: ivals(:)
[5190]2058  IF(     PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, bool2str(def), lDisp)
2059  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, lDisp=lDisp)
[5001]2060  IF(lerr) RETURN
2061  ivals = str2bool(svals)
[5190]2062  ll = ivals == -1
2063  lerr = ANY(ll); IF(.NOT.lerr) THEN; val = ivals == 1; IF(PRESENT(nam)) nam = tname; RETURN; END IF
[5001]2064  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not'
2065  CALL msg(TRIM(s)//' a boolean: '//TRIM(strStack(svals, MASK=ll)), modname)
2066END FUNCTION getKeyByIndex_lmmm
2067!==============================================================================================================================
2068
2069
2070
2071!==============================================================================================================================
2072!===                                           GET KEYS VALUES FROM TRACERS NAMES                                           ===
2073!==============================================================================================================================
2074!=== TRY TO GET THE KEY NAMED "key" FOR THE TRACER NAMED "tname" IN:                                                        ===
2075!===  * ARGUMENT "ky" DATABASE IF SPECIFIED ; OTHERWISE:                                                                    ===
[5190]2076!===  * IN INTERNAL TRACERS DATABASE "tracers(:)%keys" (IF UNFOUND, IN INTERNAL ISOTOPES DATABASE "isotope%keys(:)")        ===
[5001]2077!=== THE RETURNED VALUE (STRING, AN INTEGER, A REAL OR A LOGICAL) CAN BE EITHER:                                            ===
2078!===  * A SCALAR                                                                                                            ===
2079!===  * A VECTOR, WHICH IS THE FOUND VALUE PARSED WITH THE SEPARATOR ","                                                    ===
2080!===                                                                                                                        ===
2081!=== SYNTAX:       lerr = getKeyByName_{sirl}{1m}{1m}1(keyn[(:)], val[(:)], tname  [, ky(:)][, def][, lDisp])               ===
2082!==============================================================================================================================
2083!=== IF "tname(:)" IS A VECTOR, THE RETURNED VALUES (ONE EACH "tname(:)" ELEMENT) ARE STORED IN THE VECTOR "val(:)"         ===
2084!===                                                                                                                        ===
2085!=== SYNTAX        lerr = getKeyByName_{sirl}{1m}mm   (keyn[(:)], val (:), tname(:)[, ky(:)][, def][, lDisp])               ===
2086!==============================================================================================================================
2087LOGICAL FUNCTION getKeyByName_s111(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2088  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname
2089  CHARACTER(LEN=maxlen),     INTENT(OUT) :: val
2090  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
2091  CHARACTER(LEN=*),OPTIONAL, INTENT(IN)  :: def
2092  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
2093  lerr = getKeyByName_sm11([keyn], val, tname, ky, def, lDisp)
2094END FUNCTION getKeyByName_s111
2095!==============================================================================================================================
2096LOGICAL FUNCTION getKeyByName_i111(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2097  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname
2098  INTEGER,                   INTENT(OUT) :: val
2099  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
2100  INTEGER,         OPTIONAL, INTENT(IN)  :: def
2101  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
2102  lerr = getKeyByName_im11([keyn], val, tname, ky, def, lDisp)
2103END FUNCTION getKeyByName_i111
2104!==============================================================================================================================
2105LOGICAL FUNCTION getKeyByName_r111(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2106  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname
2107  REAL   ,                   INTENT(OUT) :: val
2108  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
2109  REAL,            OPTIONAL, INTENT(IN)  :: def
2110  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
2111  lerr = getKeyByName_rm11([keyn], val, tname, ky, def, lDisp)
2112END FUNCTION getKeyByName_r111
2113!==============================================================================================================================
2114LOGICAL FUNCTION getKeyByName_l111(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2115  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname
2116  LOGICAL,                   INTENT(OUT) :: val
2117  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
2118  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
2119  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
2120  lerr = getKeyByName_lm11([keyn], val, tname, ky, def, lDisp)
2121END FUNCTION getKeyByName_l111
2122!==============================================================================================================================
2123!==============================================================================================================================
2124LOGICAL FUNCTION getKeyByName_sm11(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2125  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname
2126  CHARACTER(LEN=maxlen),     INTENT(OUT) :: val
2127  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
2128  CHARACTER(LEN=*),OPTIONAL, INTENT(IN)  :: def
2129  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
2130!------------------------------------------------------------------------------------------------------------------------------
2131  CHARACTER(LEN=maxlen) :: s, tnam
2132  LOGICAL :: lD
2133  lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp
2134  s = 'key "'//TRIM(strStack(keyn, '/'))//'" for "'//TRIM(tname)//'"'
2135  lerr = .TRUE.
2136  tnam = strHead(delPhase(tname),'_',.TRUE.)                                             !--- Remove phase and tag
2137  IF(lerr .AND. PRESENT(ky))         val = fgetKey(ky)                                   !--- "ky"
[5190]2138  IF(lerr .AND. ALLOCATED (tracers)) val = fgetKey(tracers(:)%keys)                      !--- "tracers"
[5001]2139  IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:))                      !--- "isotope"
2140  IF(lerr .AND. PRESENT(def)) THEN
2141     val = def; lerr = .NOT.PRESENT(def)
2142     CALL msg('Using defaut value of '//TRIM(s)//': '//TRIM(def), modname, lD)
[4328]2143  END IF
[5001]2144  CALL msg('No '//TRIM(s)//' or out of bounds index', modname, lD .AND. lerr)
2145
2146CONTAINS
2147
2148 CHARACTER(LEN=maxlen) FUNCTION fgetKey(ky) RESULT(val)
2149  TYPE(keys_type),  INTENT(IN)  :: ky(:)
[5190]2150  lerr = SIZE(ky) == 0
2151  IF(lerr) RETURN
2152           val = fgetKeyIdx(strIdx(ky%name, tname), [keyn], ky, lerr)
2153  IF(lerr) val = fgetKeyIdx(strIdx(ky%name, tnam ), [keyn], ky, lerr)
2154
[5001]2155END FUNCTION fgetKey
2156
2157END FUNCTION getKeyByName_sm11
[4325]2158!==============================================================================================================================
[5001]2159LOGICAL FUNCTION getKeyByName_im11(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2160  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname
[4046]2161  INTEGER,                   INTENT(OUT) :: val
2162  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
[5001]2163  INTEGER,         OPTIONAL, INTENT(IN)  :: def
2164  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
[4301]2165!------------------------------------------------------------------------------------------------------------------------------
[5001]2166  CHARACTER(LEN=maxlen) :: sval, s
2167  IF(     PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, int2str(def), lDisp)
2168  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp)
2169  IF(lerr) RETURN
2170  val = str2int(sval)
[5190]2171  lerr = val == -HUGE(1)
[5001]2172  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not'
2173  CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr)
2174END FUNCTION getKeyByName_im11
[4046]2175!==============================================================================================================================
[5001]2176LOGICAL FUNCTION getKeyByName_rm11(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2177  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname
2178  REAL   ,                   INTENT(OUT) :: val
2179  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
2180  REAL,            OPTIONAL, INTENT(IN)  :: def
2181  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
[4301]2182!------------------------------------------------------------------------------------------------------------------------------
[5001]2183  CHARACTER(LEN=maxlen) :: sval, s
2184  IF(     PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, real2str(def), lDisp)
2185  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp)
2186  IF(lerr) RETURN
2187  val = str2real(sval)
[5190]2188  lerr = val == -HUGE(1.)
[5001]2189  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not'
2190  CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr)
2191END FUNCTION getKeyByName_rm11
[4328]2192!==============================================================================================================================
[5001]2193LOGICAL FUNCTION getKeyByName_lm11(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2194  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname
2195  LOGICAL,                   INTENT(OUT) :: val
2196  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
2197  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
2198  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
[4328]2199!------------------------------------------------------------------------------------------------------------------------------
[5001]2200  CHARACTER(LEN=maxlen) :: sval, s
2201  INTEGER               :: ival
2202  IF(     PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, bool2str(def), lDisp)
2203  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp)
2204  IF(lerr) RETURN
2205  ival = str2bool(sval)
[5190]2206  lerr = ival == -1
[5001]2207  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not'
2208  CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr)
2209  IF(.NOT.lerr) val = ival == 1
2210END FUNCTION getKeyByName_lm11
[4046]2211!==============================================================================================================================
[5001]2212!==============================================================================================================================
2213LOGICAL FUNCTION getKeyByName_s1m1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2214  CHARACTER(LEN=*),                   INTENT(IN)  :: keyn, tname
2215  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
2216  TYPE(keys_type),          OPTIONAL, INTENT(IN)  :: ky(:)
2217  CHARACTER(LEN=*),         OPTIONAL, INTENT(IN)  :: def
2218  LOGICAL,                  OPTIONAL, INTENT(IN)  :: lDisp
[4325]2219!------------------------------------------------------------------------------------------------------------------------------
[5001]2220  CHARACTER(LEN=maxlen)              :: sval
2221  lerr = getKeyByName_sm11([keyn], sval, tname, ky, def, lDisp); IF(lerr) RETURN
2222  lerr = strParse(sval, ',', val)
2223  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
2224END FUNCTION getKeyByName_s1m1
[4325]2225!==============================================================================================================================
[5001]2226LOGICAL FUNCTION getKeyByName_i1m1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2227  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname
2228  INTEGER,      ALLOCATABLE, INTENT(OUT) :: val(:)
[4046]2229  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
[5001]2230  INTEGER,         OPTIONAL, INTENT(IN)  :: def
2231  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
[4301]2232!------------------------------------------------------------------------------------------------------------------------------
[5001]2233  CHARACTER(LEN=maxlen)              :: sval, s
2234  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
2235  IF(     PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, int2str(def), lDisp)
2236  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, lDisp=lDisp)
2237  IF(lerr) RETURN
2238  lerr = strParse(sval, ',', svals)
2239  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
2240  val = str2int(svals)
[5190]2241  lerr = ANY(val == -HUGE(1))
[5001]2242  s = 'key "'//TRIM(keyn)//'" of '//TRIM(tname)//' is not'
2243  CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr)
2244END FUNCTION getKeyByName_i1m1
[4046]2245!==============================================================================================================================
[5001]2246LOGICAL FUNCTION getKeyByName_r1m1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2247  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname
2248  REAL,         ALLOCATABLE, INTENT(OUT) :: val(:)
2249  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
2250  REAL,            OPTIONAL, INTENT(IN)  :: def
2251  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
[4301]2252!------------------------------------------------------------------------------------------------------------------------------
[5001]2253  CHARACTER(LEN=maxlen)              :: sval, s
2254  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
2255  IF(     PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, real2str(def), lDisp)
2256  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, lDisp=lDisp)
2257  IF(lerr) RETURN
2258  lerr = strParse(sval, ',', svals)
2259  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
2260  val = str2real(svals)
[5190]2261  lerr = ANY(val == -HUGE(1.))
[5001]2262  s = 'key "'//TRIM(keyn)//'" of '//TRIM(tname)//' is not'
2263  CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr)
2264END FUNCTION getKeyByName_r1m1
[4328]2265!==============================================================================================================================
[5001]2266LOGICAL FUNCTION getKeyByName_l1m1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2267  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname
2268  LOGICAL,      ALLOCATABLE, INTENT(OUT) :: val(:)
2269  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
2270  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
2271  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
[4328]2272!------------------------------------------------------------------------------------------------------------------------------
[5001]2273  CHARACTER(LEN=maxlen)              :: sval, s
2274  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
2275  INTEGER,               ALLOCATABLE :: ivals(:)
2276  IF(     PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, bool2str(def), lDisp)
2277  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, lDisp=lDisp)
2278  IF(lerr) RETURN
2279  lerr = strParse(sval, ',', svals)
2280  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
2281  ivals = str2bool(svals)
[5190]2282  lerr = ANY(ivals == -1)
[5001]2283  s = 'key "'//TRIM(keyn)//'" of '//TRIM(tname)//' is not'
2284  CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr)
2285  IF(.NOT.lerr) val = ivals == 1
2286END FUNCTION getKeyByName_l1m1
[4046]2287!==============================================================================================================================
[5001]2288!==============================================================================================================================
2289LOGICAL FUNCTION getKeyByName_smm1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2290  CHARACTER(LEN=*),                   INTENT(IN)  :: keyn(:), tname
2291  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
2292  TYPE(keys_type),          OPTIONAL, INTENT(IN)  :: ky(:)
2293  CHARACTER(LEN=*),         OPTIONAL, INTENT(IN)  :: def
2294  LOGICAL,                  OPTIONAL, INTENT(IN)  :: lDisp
[4328]2295!------------------------------------------------------------------------------------------------------------------------------
[5003]2296  CHARACTER(LEN=maxlen) :: sval
[5001]2297  lerr = getKeyByName_sm11(keyn, sval, tname, ky, def, lDisp); IF(lerr) RETURN
2298  lerr = strParse(sval, ',', val)
2299  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
2300END FUNCTION getKeyByName_smm1
[4328]2301!==============================================================================================================================
[5001]2302LOGICAL FUNCTION getKeyByName_imm1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2303  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname
2304  INTEGER,      ALLOCATABLE, INTENT(OUT) :: val(:)
[4328]2305  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
[5001]2306  INTEGER,         OPTIONAL, INTENT(IN)  :: def
2307  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
[4328]2308!------------------------------------------------------------------------------------------------------------------------------
[5001]2309  CHARACTER(LEN=maxlen)              :: sval, s
2310  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
2311  IF(     PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, int2str(def), lDisp)
2312  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp)
2313  IF(lerr) RETURN
2314  lerr = strParse(sval, ',', svals)
2315  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
2316  val = str2int(svals)
[5190]2317  lerr = ANY(val == -HUGE(1))
[5001]2318  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not'
2319  CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr)
2320END FUNCTION getKeyByName_imm1
[4328]2321!==============================================================================================================================
[5001]2322LOGICAL FUNCTION getKeyByName_rmm1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2323  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname
2324  REAL,         ALLOCATABLE, INTENT(OUT) :: val(:)
2325  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
2326  REAL,            OPTIONAL, INTENT(IN)  :: def
2327  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
[4325]2328!------------------------------------------------------------------------------------------------------------------------------
[5001]2329  CHARACTER(LEN=maxlen)              :: sval, s
2330  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
2331  IF(     PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, real2str(def), lDisp)
2332  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp)
2333  IF(lerr) RETURN
2334  lerr = strParse(sval, ',', svals)
2335  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
2336  val = str2real(svals)
[5190]2337  lerr = ANY(val == -HUGE(1.))
[5001]2338  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not'
2339  CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr)
2340END FUNCTION getKeyByName_rmm1
[4325]2341!==============================================================================================================================
[5001]2342LOGICAL FUNCTION getKeyByName_lmm1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2343  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname
2344  LOGICAL,      ALLOCATABLE, INTENT(OUT) :: val(:)
2345  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
2346  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
2347  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
[4328]2348!------------------------------------------------------------------------------------------------------------------------------
[5001]2349  CHARACTER(LEN=maxlen)              :: sval, s
2350  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
2351  INTEGER,               ALLOCATABLE :: ivals(:)
2352  IF(     PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, bool2str(def), lDisp)
2353  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp)
2354  IF(lerr) RETURN
2355  lerr = strParse(sval, ',', svals)
2356  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
2357  ivals = str2bool(svals)
[5190]2358  lerr = ANY(ivals == -1)
[5001]2359  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not'
2360  CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr)
2361  IF(.NOT.lerr) val = ivals == 1
2362END FUNCTION getKeyByName_lmm1
[4328]2363!==============================================================================================================================
[5001]2364!==============================================================================================================================
2365LOGICAL FUNCTION getKeyByName_s1mm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2366  CHARACTER(LEN=*),                   INTENT(IN)  :: keyn, tname(:)
2367  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
2368  TYPE(keys_type),       OPTIONAL,    INTENT(IN)  ::  ky(:)
2369  CHARACTER(LEN=*),      OPTIONAL,    INTENT(IN)  :: def
2370  LOGICAL,               OPTIONAL,    INTENT(IN)  :: lDisp
2371  lerr = getKeyByName_smmm([keyn], val, tname, ky, def, lDisp)
2372END FUNCTION getKeyByName_s1mm
2373!==============================================================================================================================
2374LOGICAL FUNCTION getKeyByName_i1mm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2375  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname(:)
2376  INTEGER,      ALLOCATABLE, INTENT(OUT) :: val(:)
2377  TYPE(keys_type), OPTIONAL, INTENT(IN)  ::  ky(:)
2378  INTEGER,         OPTIONAL, INTENT(IN)  :: def
2379  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
2380  lerr = getKeyByName_immm([keyn], val, tname, ky, def, lDisp)
2381END FUNCTION getKeyByName_i1mm
2382!==============================================================================================================================
2383LOGICAL FUNCTION getKeyByName_r1mm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2384  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname(:)
2385  REAL,         ALLOCATABLE, INTENT(OUT) :: val(:)
2386  TYPE(keys_type), OPTIONAL, INTENT(IN)  ::  ky(:)
2387  REAL,            OPTIONAL, INTENT(IN)  :: def
2388  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
2389  lerr = getKeyByName_rmmm([keyn], val, tname, ky, def, lDisp)
2390END FUNCTION getKeyByName_r1mm
2391!==============================================================================================================================
2392LOGICAL FUNCTION getKeyByName_l1mm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2393  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname(:)
2394  LOGICAL,      ALLOCATABLE, INTENT(OUT) :: val(:)
2395  TYPE(keys_type), OPTIONAL, INTENT(IN)  ::  ky(:)
2396  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
2397  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
2398  lerr = getKeyByName_lmmm([keyn], val, tname, ky, def, lDisp)
2399END FUNCTION getKeyByName_l1mm
2400!==============================================================================================================================
2401!==============================================================================================================================
2402LOGICAL FUNCTION getKeyByName_smmm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2403  CHARACTER(LEN=*),                   INTENT(IN)  :: keyn(:), tname(:)
2404  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) ::  val(:)
2405  TYPE(keys_type),       OPTIONAL,    INTENT(IN)  ::   ky(:)
2406  CHARACTER(LEN=*),      OPTIONAL,    INTENT(IN)  ::   def
2407  LOGICAL,               OPTIONAL,    INTENT(IN)  :: lDisp
[4328]2408!------------------------------------------------------------------------------------------------------------------------------
[5001]2409  CHARACTER(LEN=maxlen) :: s
[4363]2410  INTEGER :: iq, nq
[5001]2411  LOGICAL :: lD
2412  nq = SIZE(tname); ALLOCATE(val(nq))
2413  lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp
2414  s = 'key "'//TRIM(strStack(keyn, '/'))//'"'
2415  lerr = .TRUE.
2416  IF(PRESENT(ky)) THEN;                 val = fgetKey(ky)                                !--- "ky"
[5190]2417  ELSE IF(ALLOCATED(tracers)) THEN;     val = fgetKey(tracers(:)%keys)                   !--- "tracers"
[5001]2418     IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:))                   !--- "isotope"
2419  END IF
2420  IF(.NOT.PRESENT(def)) THEN; CALL msg('No '//TRIM(s)//' found', modname, lD); RETURN; END IF
2421
2422  !--- DEFAULT VALUE
2423  val = [(def, iq = 1, SIZE(tname))]
2424  CALL msg('Using defaut value for '//TRIM(s)//': '//TRIM(def), modname, lD)
2425
2426CONTAINS
2427
2428FUNCTION fgetKey(ky) RESULT(val)
2429  CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:)
2430  TYPE(keys_type),       INTENT(IN)  :: ky(:)
2431  LOGICAL,               ALLOCATABLE :: ler(:)
[5190]2432  lerr = SIZE(ky) == 0; IF(lerr) RETURN
[5001]2433  ALLOCATE(ler(SIZE(tname)))
[5190]2434  val = [(fgetKeyIdx(strIdx(ky(:)%name, tname(iq)), keyn, ky, ler(iq)), iq = 1, SIZE(tname))]
[5001]2435  lerr = ANY(ler)
2436END FUNCTION fgetKey
2437
2438END FUNCTION getKeyByName_smmm
[4328]2439!==============================================================================================================================
[5001]2440LOGICAL FUNCTION getKeyByName_immm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2441  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname(:)
2442  INTEGER,      ALLOCATABLE, INTENT(OUT) ::  val(:)
2443  TYPE(keys_type), OPTIONAL, INTENT(IN)  ::   ky(:)
2444  INTEGER,         OPTIONAL, INTENT(IN)  ::  def
2445  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
2446!------------------------------------------------------------------------------------------------------------------------------
2447  CHARACTER(LEN=maxlen) :: s
2448  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
2449  LOGICAL,               ALLOCATABLE ::    ll(:)
2450  IF(     PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, int2str(def), lDisp)
2451  IF(.NOT.PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, lDisp=lDisp)
2452  IF(lerr) RETURN
2453  val = str2int(svals)
[5190]2454  ll = val == -HUGE(1)
[5001]2455  lerr = ANY(ll); IF(.NOT.lerr) RETURN
2456  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not'
2457  CALL msg(TRIM(s)//' an integer: '//TRIM(strStack(svals, MASK=ll)), modname)
2458END FUNCTION getKeyByName_immm
2459!==============================================================================================================================
2460LOGICAL FUNCTION getKeyByName_rmmm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2461  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname(:)
2462  REAL,         ALLOCATABLE, INTENT(OUT) ::  val(:)
2463  TYPE(keys_type), OPTIONAL, INTENT(IN)  ::   ky(:)
2464  REAL,            OPTIONAL, INTENT(IN)  ::  def
2465  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
2466!------------------------------------------------------------------------------------------------------------------------------
2467  CHARACTER(LEN=maxlen) :: s
2468  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
2469  LOGICAL,               ALLOCATABLE ::    ll(:)
2470  IF(     PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, real2str(def), lDisp)
2471  IF(.NOT.PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, lDisp=lDisp)
2472  IF(lerr) RETURN
2473  val = str2real(svals)
[5190]2474  ll = val == -HUGE(1.)
[5001]2475  lerr = ANY(ll); IF(.NOT.lerr) RETURN
2476  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not'
2477  CALL msg(TRIM(s)//' a real: '//TRIM(strStack(svals, MASK=ll)), modname)
2478END FUNCTION getKeyByName_rmmm
2479!==============================================================================================================================
2480LOGICAL FUNCTION getKeyByName_lmmm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
2481  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname(:)
2482  LOGICAL,      ALLOCATABLE, INTENT(OUT) ::  val(:)
2483  TYPE(keys_type), OPTIONAL, INTENT(IN)  ::   ky(:)
2484  LOGICAL,         OPTIONAL, INTENT(IN)  ::  def
2485  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
2486!------------------------------------------------------------------------------------------------------------------------------
[5003]2487  CHARACTER(LEN=maxlen) :: s
[5001]2488  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
2489  LOGICAL,               ALLOCATABLE ::    ll(:)
2490  INTEGER,               ALLOCATABLE :: ivals(:)
2491  IF(     PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, bool2str(def), lDisp)
2492  IF(.NOT.PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, lDisp=lDisp)
2493  IF(lerr) RETURN
2494  ivals = str2bool(svals)
[5190]2495  ll = ivals == -1
[5001]2496  lerr = ANY(ll); IF(.NOT.lerr) THEN; val = ivals == 1; RETURN; END IF
2497  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not'
2498  CALL msg(TRIM(s)//' a boolean: '//TRIM(strStack(svals, MASK=ll)), modname)
2499END FUNCTION getKeyByName_lmmm
2500!==============================================================================================================================
[4046]2501
2502
2503!==============================================================================================================================
[4325]2504!=== ROUTINES TO GET OR PUT TRACERS AND ISOTOPES DATABASES, SINCE tracers AND isotopes ARE PRIVATE VARIABLES ==================
2505!==============================================================================================================================
2506SUBROUTINE setKeysDBase(tracers_, isotopes_, isotope_)
[5190]2507  TYPE(trac_type), OPTIONAL, INTENT(IN) ::  tracers_(:)
[4325]2508  TYPE(isot_type), OPTIONAL, INTENT(IN) :: isotopes_(:)
2509  TYPE(isot_type), OPTIONAL, INTENT(IN) :: isotope_
2510!------------------------------------------------------------------------------------------------------------------------------
2511  TYPE(isot_type), ALLOCATABLE :: iso(:)
2512  INTEGER :: ix, nbIso
2513  IF(PRESENT( tracers_)) THEN;  tracers =  tracers_; ELSE; ALLOCATE( tracers(0)); END IF
2514  IF(PRESENT(isotopes_)) THEN; isotopes = isotopes_; ELSE; ALLOCATE(isotopes(0)); END IF
2515  IF(PRESENT(isotope_ )) THEN
[5190]2516    ix = strIdx(isotopes(:)%parent, isotope_%parent)
[4325]2517    IF(ix /= 0) THEN
2518      isotopes(ix) = isotope_
2519    ELSE
2520      nbIso = SIZE(isotopes); ALLOCATE(iso(nbIso+1)); iso(1:nbIso) = isotopes; iso(nbIso+1) = isotope_
2521      CALL MOVE_ALLOC(FROM=iso, TO=isotopes)
2522    END IF
2523  END IF
2524END SUBROUTINE setKeysDBase
2525!==============================================================================================================================
2526SUBROUTINE getKeysDBase(tracers_, isotopes_, isotope_)
[5190]2527  TYPE(trac_type), OPTIONAL, ALLOCATABLE, INTENT(OUT) ::  tracers_(:)
[4325]2528  TYPE(isot_type), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: isotopes_(:)
2529  TYPE(isot_type), OPTIONAL,              INTENT(OUT) :: isotope_
2530!------------------------------------------------------------------------------------------------------------------------------
2531  INTEGER :: ix
2532  IF(PRESENT( tracers_)) THEN;  tracers_ =  tracers; ELSE; ALLOCATE( tracers_(0)); END IF
2533  IF(PRESENT(isotopes_)) THEN; isotopes_ = isotopes; ELSE; ALLOCATE(isotopes_(0)); END IF
[5190]2534  IF(PRESENT(isotope_ )) THEN; ix = strIdx(isotopes(:)%parent, isotope%parent); IF(ix /= 0) isotope_=isotopes(ix); END IF
[4325]2535END SUBROUTINE getKeysDBase
2536!==============================================================================================================================
2537
2538
2539!==============================================================================================================================
[4046]2540!=== REMOVE, IF ANY, OR ADD THE PHASE SUFFIX OF THE TRACER NAMED "s" ==========================================================
2541!==============================================================================================================================
2542ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION delPhase(s) RESULT(out)
[4325]2543  CHARACTER(LEN=*), INTENT(IN) :: s
[4301]2544!------------------------------------------------------------------------------------------------------------------------------
2545  INTEGER :: ix, ip, ns
2546  out = s; ns = LEN_TRIM(s)
[4394]2547  IF(s == '' .OR. ns<=2) RETURN                                                !--- Empty string or LEN(name)<=2: nothing to do
[4301]2548  IF(s(1:3)=='H2O' .AND. INDEX(old_phases,s(4:4))/=0 .AND. (ns==4 .OR. s(5:5)=='_')) THEN
2549    out='H2O'//s(5:ns)                                                         !--- H2O<phase>[_<iso>][_<tag>]
2550  ELSE IF(s(ns-1:ns-1)==phases_sep .AND. INDEX(known_phases,s(ns:ns))/=0) THEN
2551    out = s(1:ns-2); RETURN                                                    !--- <var><phase_sep><phase>
2552  ELSE; DO ip = 1, nphases; ix = INDEX(s, phases_sep//known_phases(ip:ip)//'_'); IF(ix /= 0) EXIT; END DO
2553    IF(ip /= nphases+1) out = s(1:ix-1)//s(ix+2:ns)                            !--- <var><phase_sep><phase>_<tag>
[4046]2554  END IF
2555END FUNCTION delPhase
[4301]2556!==============================================================================================================================
[4120]2557CHARACTER(LEN=maxlen) FUNCTION addPhase_s1(s,pha) RESULT(out)
[4063]2558  CHARACTER(LEN=*),           INTENT(IN) :: s
2559  CHARACTER(LEN=1),           INTENT(IN) :: pha
[4301]2560!------------------------------------------------------------------------------------------------------------------------------
[4046]2561  INTEGER :: l, i
2562  out = s
2563  IF(s == '') RETURN                                                           !--- Empty string: nothing to do
2564  i = INDEX(s, '_')                                                            !--- /=0 for <var>_<tag> tracers names
2565  l = LEN_TRIM(s)
[4120]2566  IF(i == 0) out =  TRIM(s)//phases_sep//pha                                   !--- <var>       => return <var><sep><pha>
2567  IF(i /= 0) out = s(1:i-1)//phases_sep//pha//'_'//s(i+1:l)                    !--- <var>_<tag> => return <var><sep><pha>_<tag>
2568END FUNCTION addPhase_s1
[4301]2569!==============================================================================================================================
[4120]2570FUNCTION addPhase_sm(s,pha) RESULT(out)
[4063]2571  CHARACTER(LEN=*),           INTENT(IN) :: s(:)
2572  CHARACTER(LEN=1),           INTENT(IN) :: pha
2573  CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
[4301]2574!------------------------------------------------------------------------------------------------------------------------------
[4046]2575  INTEGER :: k
[4120]2576  out = [( addPhase_s1(s(k), pha), k=1, SIZE(s) )]
2577END FUNCTION addPhase_sm
[4301]2578!==============================================================================================================================
[4120]2579CHARACTER(LEN=maxlen) FUNCTION addPhase_i1(s,ipha,phases) RESULT(out)
2580  CHARACTER(LEN=*),           INTENT(IN) :: s
2581  INTEGER,                    INTENT(IN) :: ipha
2582  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases
[4301]2583!------------------------------------------------------------------------------------------------------------------------------
[4120]2584  out = s
2585  IF(s == '') RETURN                                                           !--- Empty string: nothing to do
[4301]2586  IF(ipha == 0 .OR. ipha > nphases) RETURN                                     !--- Absurd index: no phase to add
[4120]2587  IF(     PRESENT(phases)) out = addPhase_s1(s,       phases(ipha:ipha))
2588  IF(.NOT.PRESENT(phases)) out = addPhase_s1(s, known_phases(ipha:ipha))
2589END FUNCTION addPhase_i1
[4301]2590!==============================================================================================================================
[4120]2591FUNCTION addPhase_im(s,ipha,phases) RESULT(out)
2592  CHARACTER(LEN=*),           INTENT(IN) :: s(:)
2593  INTEGER,                    INTENT(IN) :: ipha
2594  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases
2595  CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
[4301]2596!------------------------------------------------------------------------------------------------------------------------------
[4120]2597  INTEGER :: k
2598  IF(     PRESENT(phases)) out = [( addPhase_i1(s(k), ipha,       phases), k=1, SIZE(s) )]
2599  IF(.NOT.PRESENT(phases)) out = [( addPhase_i1(s(k), ipha, known_phases), k=1, SIZE(s) )]
2600END FUNCTION addPhase_im
[4301]2601!==============================================================================================================================
[4046]2602
2603
[4120]2604!==============================================================================================================================
[4987]2605!=== APPEND TRACERS DATABASE "tracs" WITH TRACERS/KEYS "tname"/"keys" ; SAME FOR INTERNAL DATABASE "tracers" ==================
2606!==============================================================================================================================
[5001]2607LOGICAL FUNCTION addTracer_1(tname, keys, tracs) RESULT(lerr)
[4987]2608  CHARACTER(LEN=*),             INTENT(IN)    :: tname
2609  TYPE(keys_type),              INTENT(IN)    ::  keys
[5190]2610  TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tracs(:)
2611  TYPE(trac_type), ALLOCATABLE :: tr(:)
[5001]2612  CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:)
[4987]2613  INTEGER :: nt, ix
2614  IF(ALLOCATED(tracs)) THEN
[5190]2615     lerr = getKey('name', tnames, ky=tracs(:)%keys); IF(lerr) RETURN
[4987]2616     nt = SIZE(tracs)
[5001]2617     ix = strIdx(tnames, tname)
[4987]2618     CALL msg('Modifying existing tracer "'//TRIM(tname)//'"', modname, ix /= 0)
2619     CALL msg('Appending with tracer "'    //TRIM(tname)//'"', modname, ix == 0)
2620     IF(ix == 0) THEN
2621        ix = nt+1; ALLOCATE(tr(nt+1)); tr(1:nt) = tracs(1:nt); CALL MOVE_ALLOC(FROM=tr, TO=tracs)
2622     END IF
2623  ELSE
2624     CALL msg('Creating a tracer descriptor with tracer "'//TRIM(tname)//'"', modname)
2625     ix = 1; ALLOCATE(tracs(1))
2626  END IF
[5190]2627  CALL addKey('name', tname, tracs(ix)%keys)
2628  tracs(ix)%name = tname
2629  tracs(ix)%keys = keys
[5001]2630
2631END FUNCTION addTracer_1
[4987]2632!==============================================================================================================================
[5001]2633LOGICAL FUNCTION addTracer_1def(tname, keys) RESULT(lerr)
[4987]2634  CHARACTER(LEN=*),             INTENT(IN)    :: tname
2635  TYPE(keys_type),              INTENT(IN)    ::  keys
[5001]2636  lerr = addTracer_1(tname, keys, tracers)
2637END FUNCTION addTracer_1def
[4987]2638!==============================================================================================================================
2639
2640
2641!==============================================================================================================================
[5001]2642LOGICAL FUNCTION delTracer_1(tname, tracs) RESULT(lerr)
[4987]2643  CHARACTER(LEN=*),                     INTENT(IN)    :: tname
[5190]2644  TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: tracs(:)
2645  TYPE(trac_type), ALLOCATABLE :: tr(:)
[5001]2646  CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:)
[4987]2647  INTEGER :: nt, ix
2648  lerr = .NOT.ALLOCATED(tracs)
2649  IF(fmsg('Can''t remove tracer "'//TRIM(tname)//'" from an empty tracers descriptor', modname, lerr)) RETURN
2650  nt = SIZE(tracs)
[5190]2651  lerr = getKey('name', tnames, ky=tracs(:)%keys); IF(lerr) RETURN
[5001]2652  ix = strIdx(tnames, tname)
[4987]2653  CALL msg('Removing tracer "'             //TRIM(tname)//'"', modname, ix /= 0)
2654  CALL msg('Can''t remove unknown tracer "'//TRIM(tname)//'"', modname, ix == 0)
2655  IF(ix /= 0) THEN
2656     ALLOCATE(tr(nt-1)); tr(1:ix-1) = tracs(1:ix-1); tr(ix:nt-1) = tracs(ix+1:nt); CALL MOVE_ALLOC(FROM=tr, TO=tracs)
2657  END IF
2658END FUNCTION delTracer_1
2659!==============================================================================================================================
2660LOGICAL FUNCTION delTracer_1def(tname) RESULT(lerr)
2661  CHARACTER(LEN=*), INTENT(IN) :: tname
2662  lerr = delTracer(tname, tracers)
2663END FUNCTION delTracer_1def
2664!==============================================================================================================================
2665
2666
2667!==============================================================================================================================
[4120]2668!=== GET PHASE INDEX IN THE POSSIBLE PHASES LIST OR IN A SPECIFIED LIST ("phases") ============================================
2669!==============================================================================================================================
2670INTEGER FUNCTION getiPhase(tname, phases) RESULT(iPhase)
2671  CHARACTER(LEN=*),           INTENT(IN)  :: tname
2672  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: phases
[4301]2673!------------------------------------------------------------------------------------------------------------------------------
[4120]2674  CHARACTER(LEN=maxlen) :: phase
2675  IF(     PRESENT(phases)) phase = getPhase(tname,       phases, iPhase)
2676  IF(.NOT.PRESENT(phases)) phase = getPhase(tname, known_phases, iPhase)
2677END FUNCTION getiPhase
[4301]2678!==============================================================================================================================
[4120]2679CHARACTER(LEN=1) FUNCTION getPhase(tname, phases, iPhase) RESULT(phase)
2680  CHARACTER(LEN=*),           INTENT(IN)  :: tname
2681  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: phases
2682  INTEGER,          OPTIONAL, INTENT(OUT) :: iPhase
[4301]2683!------------------------------------------------------------------------------------------------------------------------------
[4120]2684  INTEGER :: ip
[4403]2685  phase = TRIM(strHead(strTail(tname, phases_sep), '_', .TRUE.))     !--- <nam><sep><pha>[_<tag>] -> <pha>[_<tag>] -> <pha>
[4120]2686  IF(     PRESENT(phases)) ip = INDEX(      phases, phase)
2687  IF(.NOT.PRESENT(phases)) ip = INDEX(known_phases, phase)
2688  IF(ip == 0) phase = 'g'
2689  IF(PRESENT(iPhase)) iPhase = ip
2690END FUNCTION getPhase
[4301]2691!==============================================================================================================================
[4067]2692
[4120]2693
[4301]2694!==============================================================================================================================
[5190]2695!============ CONVERT WATER-DERIVED NAMES FROM FORMER TO CURRENT CONVENTION ; OTHER NAMES ARE LEFT UNTOUCHED ==================
2696!======= NAMES STRUCTURE: H2O[<phase>][_<isotope>][_<tag>] (<phase> from "old_phases", <isotope> from "oldH2OIso") ============
[4301]2697!==============================================================================================================================
2698CHARACTER(LEN=maxlen) FUNCTION old2newH2O_1(oldName, iPhase) RESULT(newName)
[4120]2699  CHARACTER(LEN=*),  INTENT(IN)  :: oldName
2700  INTEGER, OPTIONAL, INTENT(OUT) :: iPhase
[4301]2701!------------------------------------------------------------------------------------------------------------------------------
[4120]2702  CHARACTER(LEN=maxlen), ALLOCATABLE :: tmp(:)
[4301]2703  INTEGER :: ix, ip, nt
2704  LOGICAL :: lerr
[4120]2705  newName = oldName
2706  IF(PRESENT(iPhase)) iPhase = 1                                               !--- Default: gaseous phase
[4348]2707  lerr = strParse(oldName, '_', tmp, nt)                                       !--- Parsing: 1 up to 3 elements.
[4301]2708  ip = strIdx( [('H2O'//old_phases(ix:ix), ix=1, nphases)], tmp(1) )           !--- Phase index
2709  IF(ip /= 0 .AND. PRESENT(iPhase)) iPhase = ip                                !--- Returning phase index
2710  IF(ip == 0 .AND. tmp(1) /= 'H2O')   RETURN                                   !--- Not an old-style water-related species
2711  IF(nt == 1) THEN
2712    newName = addPhase('H2O',ip)                                               !=== WATER WITH OR WITHOUT PHASE
2713  ELSE
2714    ix = strIdx(oldH2OIso, tmp(2))                                             !--- Index in the known isotopes list
[4403]2715    IF(ix /= 0) newName = newH2OIso(ix)                                        !--- Move to new isotope name
2716    IF(ip /= 0) newName = addPhase(newName, ip)                                !--- Add phase to isotope name
2717    IF(nt == 3) newName = TRIM(newName)//'_'//TRIM(tmp(3))                     !=== WATER ISOTOPE OR TAGGING TRACER
[4140]2718  END IF
[4301]2719END FUNCTION old2newH2O_1
2720!==============================================================================================================================
2721FUNCTION old2newH2O_m(oldName) RESULT(newName)
2722  CHARACTER(LEN=*), INTENT(IN) :: oldName(:)
2723  CHARACTER(LEN=maxlen)        :: newName(SIZE(oldName))
[4120]2724!------------------------------------------------------------------------------------------------------------------------------
2725  INTEGER :: i
[4301]2726  newName = [(old2newH2O_1(oldName(i)), i=1, SIZE(oldName))]
2727END FUNCTION old2newH2O_m
2728!==============================================================================================================================
[5190]2729
2730
2731!==============================================================================================================================
2732!============ CONVERT WATER-DERIVED NAMES FROM CURRENT TO FORMER CONVENTION ; OTHER NAMES ARE LEFT UNTOUCHED ==================
2733!==== NAMES STRUCTURE: <var>[<phase_sep><phase>][_<tag>] (<phase> from "known_phases", <var> = 'H2O' or from "newH2OIso") =====
2734!==============================================================================================================================
[4301]2735CHARACTER(LEN=maxlen) FUNCTION new2oldH2O_1(newName, iPhase) RESULT(oldName)
2736  CHARACTER(LEN=*),  INTENT(IN)  :: newName
2737  INTEGER, OPTIONAL, INTENT(OUT) :: iPhase
[4120]2738!------------------------------------------------------------------------------------------------------------------------------
[4301]2739  INTEGER :: ix, ip
2740  CHARACTER(LEN=maxlen) :: var
2741  oldName = newName
[4120]2742  ip = getiPhase(newName)                                                      !--- Phase index
[4403]2743  IF(PRESENT(iPhase)) iPhase = MAX(ip, 1)                                      !--- Return phase index ; default: 1 (gazeous)
2744  var = TRIM(strHead(newName, phases_sep, .TRUE.))                             !--- Variable without phase and tag
[4301]2745  ix = strIdx(newH2OIso, var)                                                  !--- Index in the known H2O isotopes list
[4403]2746  IF(ix == 0 .AND. var /= 'H2O') RETURN                                        !--- Neither H2O nor an H2O isotope => finished
2747  oldName = 'H2O'
2748  IF(ip /= 0) oldName = TRIM(oldName)//old_phases(ip:ip)                       !--- Add phase if needed
2749  IF(ix /= 0) oldName = TRIM(oldName)//'_'//oldH2OIso(ix)                      !--- H2O isotope name
2750  IF(newName /= addPhase(var, ip)) &
2751    oldName = TRIM(oldName)//strTail(newName, '_', .TRUE.)                     !--- Add the tag suffix
2752  IF(ip == 0 .AND. ix /= 0) oldName = strTail(oldName, '_')                    !--- Isotope with no phase: remove 'H2O_' prefix
[4301]2753END FUNCTION new2oldH2O_1
2754!==============================================================================================================================
2755FUNCTION new2oldH2O_m(newName) RESULT(oldName)
2756  CHARACTER(LEN=*), INTENT(IN) :: newName(:)
2757  CHARACTER(LEN=maxlen)        :: oldName(SIZE(newName))
[4120]2758!------------------------------------------------------------------------------------------------------------------------------
2759  INTEGER :: i
[4301]2760  oldName = [(new2oldH2O_1(newName(i)), i=1, SIZE(newName))]
2761END FUNCTION new2oldH2O_m
2762!==============================================================================================================================
[4120]2763
[4046]2764END MODULE readTracFiles_mod
Note: See TracBrowser for help on using the repository browser.