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

Last change on this file since 5214 was 5190, checked in by dcugnet, 2 months ago

Revert to r5182 because r5183 still craches with gfortran for unclear reasons.
r5188 and r5189 have been included.

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