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

Last change on this file since 5756 was 5756, checked in by dcugnet, 4 days ago

Add "isoFamilies", the list of defined isotopes families (==H2O? for now).

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