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

Last change on this file since 5481 was 5481, checked in by dcugnet, 6 hours ago

Remove tracers attributes "isAdvected" and "isInPhysics" from infotrac (iadv is enough).
Remove tracers attribute "isAdvected" from infotrac_phy (isInPhysics is now equivalent
to former isInPhysics .AND. iadv > 0

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