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