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