![(please configure the [header_logo] section in trac.ini)](/tracers-parser/chrome/site/your_project_logo.png){kind=logo}
Changeset 6 for readTracFiles_mod.f90
- Timestamp:
- Jan 25, 2022, 12:33:27 AM (3 years ago)
- File:
-
- 1 edited
-
readTracFiles_mod.f90 (modified) (27 diffs)
Legend:
- Unmodified
- Added
- Removed
-
readTracFiles_mod.f90
r4 r6 1 1 MODULE readTracFiles_mod 2 2 3 USE strings_mod, ONLY:msg, testFile, strFind, strStack, strReduce, strHead, strCount, find, maxlen, fmsg, &4 removeComment, cat, checkList, strIdx, strParse, strReplace, strTail, reduceExpr, test, get_in, dispTable5 USE trac_types_mod, ONLY 3 USE strings_mod, ONLY: msg, testFile, strFind, strStack, strReduce, strHead, strCount, find, maxlen, fmsg, & 4 removeComment, cat, checkList, strIdx, strParse, strReplace, strTail, reduceExpr, test, get_in, dispTable 5 USE trac_types_mod, ONLY: trac_type, isot_type, keys_type 6 6 7 7 IMPLICIT NONE … … 9 9 PRIVATE 10 10 11 PUBLIC :: initIsotopes, maxlen, trac_type, isot_type 12 PUBLIC :: readTracersFiles, aliasTracer, tracersSubset, indexUpdate!--- TOOLS ASSOCIATED TO TRACERS DESCRIPTORS11 PUBLIC :: initIsotopes, maxlen, trac_type, isot_type, keys_type 12 PUBLIC :: readTracersFiles, indexUpdate, setGeneration !--- TOOLS ASSOCIATED TO TRACERS DESCRIPTORS 13 13 PUBLIC :: readIsotopesFile !--- TOOLS ASSOCIATED TO ISOTOPES DESCRIPTORS 14 14 PUBLIC :: getKey_init, getKey, setDirectKeys !--- GET/SET KEYS FROM/TO tracers & isotopes … … 45 45 CHARACTER(LEN=maxlen), SAVE :: phases_names(nphases) & !--- Known phases names 46 46 = ['gaseous', 'liquid ', 'solid '] 47 CHARACTER(LEN=1), SAVE :: phases_sep = '_'!--- Phase separator48 LOGICAL, SAVE :: tracs_merge = .TRUE.!--- Merge/stack tracers lists49 LOGICAL, SAVE :: lSortByGen = .TRUE.!--- Sort by growing generation47 CHARACTER(LEN=1), SAVE :: phases_sep = '_' !--- Phase separator 48 LOGICAL, SAVE :: tracs_merge = .TRUE. !--- Merge/stack tracers lists 49 LOGICAL, SAVE :: lSortByGen = .TRUE. !--- Sort by growing generation 50 50 51 51 !=== LOCAL COPIES OF THE TRACERS AND ISOTOPES DESCRIPTORS, USED BY getKey (INITIALIZED IN getKey_init) … … 76 76 ! * The "keys" component (of type keys_type) is in principle enough to store everything we could need. 77 77 ! But some variables are stored as direct-access keys to make the code more readable and because they are used often. 78 ! * Most of the direct-access keys are set in this module, but some are not (l nam, iadv and itr for example).78 ! * Most of the direct-access keys are set in this module, but some are not (longName, iadv, isAdvected for now). 79 79 ! * Some of the direct-access keys must be updated (using the routine "setDirectKeys") is a subset of "tracers(:)" 80 ! is extracted: the indexes are no longer valid for a subset (examples: tracers(:)%iqParent or tracers(:)%ichld).80 ! is extracted: the indexes are no longer valid for a subset (examples: iqParent, iqDescen). 81 81 ! * If you need to convert a %key/%val pair into a direct-access key, add the corresponding line in "setDirectKeys". 82 82 !============================================================================================================================== … … 87 87 TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: tracs(:) 88 88 CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:), sections(:), trac_files(:) 89 CHARACTER(LEN=maxlen) :: str, fname, mesg 90 INTEGER :: is, nsec, ierr, it, ntrac, ns, ip 89 CHARACTER(LEN=maxlen) :: str, fname, mesg, oldH2O, newH2O 90 INTEGER :: is, nsec, ierr, it, ntrac, ns, ip, ix 91 91 LOGICAL, ALLOCATABLE :: ll(:), lGen3(:) 92 92 !------------------------------------------------------------------------------------------------------------------------------ … … 111 111 END IF 112 112 113 !--- CHECK WHETHER type_trac AND FILE TYPE ARE COMPATIBLE 114 IF(test(fmsg('No multiple sections for the old format "traceur.def"', ll = SIZE(sections)>1 .AND. fType==1), lerr)) RETURN 115 113 116 !--- TELLS WHAT WAS IS ABOUT TO BE USED 114 117 IF (fmsg('No adequate tracers description file(s) found ; default values will be used', modname, fType==0)) RETURN … … 118 121 119 122 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 120 IF(fType==1) THEN !=== OLD FORMAT "traceur.def" 121 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 122 !--- OPEN THE "traceur.def" FILE 123 OPEN(90, FILE="traceur.def", FORM='formatted', STATUS='old', IOSTAT=ierr) 124 125 !--- GET THE TRACERS NUMBER 126 READ(90,'(i3)',IOSTAT=ierr)ntrac !--- Number of lines/tracers 127 IF(test(fmsg('Invalid format for "'//TRIM(fname)//'"', modname, ierr /= 0), lerr)) RETURN 128 129 !--- READ THE REMAINING LINES: <hadv> <vadv> <tracer> [<transporting fluid>] 130 ALLOCATE(tracs(ntrac)) 131 DO it=1,ntrac !=== READ RAW DATA: loop on the line/tracer number 132 READ(90,'(a)',IOSTAT=ierr) str 133 IF(test(fmsg('Invalid format for "' //TRIM(fname)//'"', modname, ierr>0), lerr)) RETURN 134 IF(test(fmsg('Not enough lines in "'//TRIM(fname)//'"', modname, ierr<0), lerr)) RETURN 135 ll = strParse(str, ' ', s, n=ns) 136 tracs(it)%keys%key = ['hadv', 'vadv'] 137 tracs(it)%keys%val = s(1:2) 138 CALL msg('This file is for air tracers only', modname, ns == 3 .AND. it == 1) 139 CALL msg('This files specifies the transporting fluid', modname, ns == 4 .AND. it == 1) 140 tracs(it)%name = TRIM(s(3)) !--- Name of the tracer 141 tracs(it)%phase = known_phases(1:1) !--- Phase (default: "g" for gazeous) 123 SELECT CASE(fType) !--- Set %name, %genOName, %parent, %type, %phase, %component, %iGeneration, %keys 124 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 125 CASE(1) !=== OLD FORMAT "traceur.def" 126 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 127 !--- OPEN THE "traceur.def" FILE 128 OPEN(90, FILE="traceur.def", FORM='formatted', STATUS='old', IOSTAT=ierr) 129 130 !--- GET THE TRACERS NUMBER 131 READ(90,'(i3)',IOSTAT=ierr)ntrac !--- Number of lines/tracers 132 IF(test(fmsg('Invalid format for "'//TRIM(fname)//'"', modname, ierr /= 0), lerr)) RETURN 133 134 !--- READ THE REMAINING LINES: <hadv> <vadv> <tracer> [<transporting fluid>] 135 ALLOCATE(tracs(ntrac)) 136 DO it=1,ntrac !=== READ RAW DATA: loop on the line/tracer number 137 READ(90,'(a)',IOSTAT=ierr) str 138 IF(test(fmsg('Invalid format for "' //TRIM(fname)//'"', modname, ierr>0), lerr)) RETURN 139 IF(test(fmsg('Not enough lines in "'//TRIM(fname)//'"', modname, ierr<0), lerr)) RETURN 140 ll = strParse(str, ' ', s, n=ns) 141 CALL msg('This file is for air tracers only', modname, ns == 3 .AND. it == 1) 142 CALL msg('This files specifies the transporting fluid', modname, ns == 4 .AND. it == 1) 143 tracs(it)%name = TRIM(s(3)) !--- Set %name: name of the tracer 144 tracs(it)%parent = tran0 !--- Set %parent: transporting fluid 145 IF(ns == 4) tracs(it)%parent = s(4) !--- default: 'air' or defined in the file 146 tracs(it)%phase = known_phases(1:1) !--- Set %phase: tracer phase (default: "g"azeous) 147 tracs(it)%component = TRIM(type_trac) !--- Set %component: model component name 148 tracs(it)%keys%key = ['hadv', 'vadv'] !--- Set %keys%key 149 tracs(it)%keys%val = s(1:2) !--- Set %keys%val 150 END DO 151 CLOSE(90) 142 152 DO ip = 1, nphases !--- Deal with old water names 143 IF(s(3) /= 'H2O'//old_phases(ip:ip)) CYCLE 144 tracs(it)%phase = known_phases(ip:ip); tracs(it)%name = 'H2O'//phases_sep//TRIM(tracs(it)%phase) 153 oldH2O = 'H2O'//old_phases(ip:ip) 154 newH2O = 'H2O'//phases_sep//known_phases(ip:ip) 155 ix = strIdx(tracs(:)%name, oldH2O) 156 IF(ix == 0) CYCLE 157 tracs(ix)%name = newH2O !--- Set %name: name of the tracer 158 WHERE(tracs(:)%parent == oldH2O) tracs(:)%parent = newH2O !--- Set %parent: transporting fluid 159 tracs(ix)%phase = known_phases(ip:ip) !--- Set %phase: tracer phase 145 160 END DO 146 tracs(it)%parent = tran0 !--- Default transporting fluid: Air 147 IF(ns == 4) tracs(it)%parent = s(4) !--- Transporting fluid name 148 END DO 149 CLOSE(90) 150 151 lGen3 = tracs%iGeneration==3 152 CALL setGeneration(tracs) !--- Determine tracs(:)%iGeneration values 153 IF(test(checkTracers(tracs, fname,fname),lerr)) RETURN !--- Detect orphans and check phases 154 IF(test(checkUnique (tracs,lGen3,fname,fname),lerr)) RETURN !--- Detect repeated tracers 155 CALL sortTracers (tracs) !--- Sort the tracers 156 CALL setDirectKeys(tracs) !--- Set the directly accessible keys 157 tracs(:)%keys%name = tracs(:)%name !--- Copy tracers names in keys components 158 RETURN 159 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 161 CALL setGeneration(tracs) !--- Set %iGeneration and %gen0Name 162 WHERE(tracs%iGeneration == 3) tracs%type = 'tag' !--- Set %type: 'tracer' or 'tag' 163 IF(test(checkTracers(tracs, fname, fname), lerr)) RETURN !--- Detect orphans and check phases 164 IF(test(checkUnique (tracs, fname, fname), lerr)) RETURN !--- Detect repeated tracers 165 CALL sortTracers (tracs) !--- Sort the tracers 166 tracs(:)%keys%name = tracs(:)%name !--- Copy tracers names in keys components 167 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 168 CASE(2); IF(test(feedDBase(["tracer.def"],[type_trac]), lerr)) RETURN !=== SINGLE FILE, COMA-SEPARATED SECTIONS LIST 169 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 170 CASE(3); IF(test(feedDBase( trac_files , sections ), lerr)) RETURN !=== MULTIPLE FILES, ONE SECTION EACH FILE 171 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 172 END SELECT 173 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 174 175 IF(ANY([2,3] == fType) .AND. nsec > 1) THEN 176 IF(tracs_merge) THEN 177 CALL msg('The multiple required sections will be MERGED.', modname) 178 IF(test(mergeTracers(dBase, tracs), lerr)) RETURN 179 ELSE 180 CALL msg('The multiple required sections will be CUMULATED.', modname) 181 IF(test(cumulTracers(dBase, tracs), lerr)) RETURN 182 END IF 183 WHERE(tracs%gen0Name(1:3) == 'H2O') tracs%isH2Ofamily=.TRUE. !--- Set %isH2Ofamily: belongs to H2O family 184 CALL setDirectKeys(tracs) !--- Set %iqParent, %iqDescen, %nqDescen, %nqChilds 160 185 END IF 161 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++162 163 !=== USING NEW FORMAT TRACERS DESCRIPTION FILES WITH POSSIBLY SEVERAL SECTIONS164 CALL msg('The multiple required sections will be MERGED.', modname, nsec > 1 .AND. tracs_merge)165 CALL msg('The multiple required sections will be CUMULATED.', modname, nsec > 1 .AND. .NOT.tracs_merge)166 167 !=== FEED THE DATABASE WITH THE RAW CONTENT OF THE FILE168 SELECT CASE(fType)169 CASE(2); lerr = feedDBase(["tracer.def"],[type_trac]) !--- Single file, coma-separated sections list170 CASE(3); lerr = feedDBase(trac_files, sections ) !--- Multiple files, one section name each file171 END SELECT172 IF(lerr) RETURN173 IF( tracs_merge) lerr = mergeTracers(dBase, tracs) !--- MERGE THE COMPONENTS OF THE DATABASE174 IF(.NOT.tracs_merge) lerr = cumulTracers(dBase, tracs) !--- CUMULATE THE COMPONENTS OF THE DATABASE175 IF(lerr) RETURN176 CALL setDirectKeys(tracs) !--- Set the directly accessible keys177 186 178 187 END FUNCTION readTracersFiles … … 201 210 ll = strCount(snames, ',', ndb) !--- Number of sections for each file 202 211 ALLOCATE(ixf(SUM(ndb))) 203 DO i=1, SIZE(fnames) 212 DO i=1, SIZE(fnames) !--- Set %name, %keys 204 213 IF(test(readSections(fnames(i), snames(i), 'default'), lerr)) RETURN 205 214 ixf(1+SUM(ndb(1:i-1)):SUM(ndb(1:i))) = i !--- File index for each section of the expanded list … … 208 217 DO idb=1,SIZE(dBase) !--- LOOP ON THE LOADED SECTIONS 209 218 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 210 fnm = fnames(ixf(idb)); snm = dBase(idb)%name 211 IF(test(expandSection(dBase(idb)%trac, snm, fnm),lerr)) RETURN !--- EXPAND NAMES AND PARENTS LISTS 212 CALL setGeneration (dBase(idb)%trac) !--- DETERMINE GENERATION NUMBER 213 IF(test(checkTracers (dBase(idb)%trac, snm, fnm),lerr)) RETURN !--- CHECK ORPHANS AND PHASES 214 lTg = dBase(idb)%trac(:)%type == 'tag' !--- Flag for tagging tracers 215 IF(test(checkUnique (dBase(idb)%trac,lTg,snm,fnm),lerr)) RETURN !--- CHECK TRACERS UNIQUENESS 216 CALL expandPhases (dBase(idb)%trac) !--- EXPAND THE PHASES 219 fnm = fnames(ixf(idb)); snm = dBase(idb)%name !--- FILE AND SECTION NAMES 220 IF(test(expandSection(dBase(idb)%trac, snm, fnm), lerr)) RETURN !--- EXPAND NAMES ; set %parent, %type, %component 221 CALL setGeneration (dBase(idb)%trac) !--- set %iGeneration, %genOName 222 IF(test(checkTracers (dBase(idb)%trac, snm, fnm), lerr)) RETURN !--- CHECK ORPHANS AND PHASES 223 IF(test(checkUnique (dBase(idb)%trac, snm, fnm), lerr)) RETURN !--- CHECK TRACERS UNIQUENESS 224 CALL expandPhases (dBase(idb)%trac) !--- EXPAND PHASES ; set %phase 217 225 CALL sortTracers (dBase(idb)%trac) !--- SORT TRACERS 218 226 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ … … 283 291 ll = strParse(str,' ', keys = s, vals = v, n = n) !--- Parse <key>=<val> pairs 284 292 tt = dBase(ndb)%trac(:) 285 tmp%name = s(1); tmp% component=secn; tmp%keys = keys_type(s(1), s(2:n), v(2:n))293 tmp%name = s(1); tmp%keys = keys_type(s(1), s(2:n), v(2:n)) !--- Set %name and %keys 286 294 dBase(ndb)%trac = [tt(:), tmp] 287 295 DEALLOCATE(tt) 288 ! dBase(ndb)%trac = [dBase(ndb)%trac(:), tra(name=s(1), comp=secn,keys=keys_type(s(1), s(2:n), v(2:n)))]296 ! dBase(ndb)%trac = [dBase(ndb)%trac(:), tra(name=s(1), keys=keys_type(s(1), s(2:n), v(2:n)))] 289 297 END IF 290 298 END DO … … 421 429 !------------------------------------------------------------------------------------------------------------------------------ 422 430 ! Purpose: Determine, for each tracer of "tr(:)": 423 ! * the generation number 424 ! * the first generation ancestor name 425 !------------------------------------------------------------------------------------------------------------------------------ 426 ! Arguments: 427 TYPE(trac_type), INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 428 !------------------------------------------------------------------------------------------------------------------------------ 429 ! Local variables: 430 INTEGER :: iq, nq, ig 431 ! * %iGeneration: the generation number 432 ! * %gen0Name: the generation 0 ancestor name 433 !------------------------------------------------------------------------------------------------------------------------------ 434 TYPE(trac_type), INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 435 INTEGER :: iq, nq, ig 431 436 LOGICAL, ALLOCATABLE :: lg(:) 432 437 CHARACTER(LEN=maxlen), ALLOCATABLE :: prn(:) 433 438 !------------------------------------------------------------------------------------------------------------------------------ 434 tr(:)%iGeneration = 0 !--- error if 0439 tr(:)%iGeneration = -1 !--- error if -1 435 440 nq = SIZE(tr, DIM=1) !--- Number of tracers lines 436 441 lg = tr(:)%parent == tran0 !--- First generation tracers flag 437 WHERE(lg) tr(:)%iGeneration = 1!--- First generation tracers442 WHERE(lg) tr(:)%iGeneration = 0 !--- First generation tracers 438 443 439 444 !=== Determine generation for each tracer 440 ig= 0; prn = [tran0]445 ig=-1; prn = [tran0] 441 446 DO !--- Update current generation flag 442 IF(ig/= 0) prn = PACK( tr(:)%name, MASK=tr(:)%iGeneration == ig)447 IF(ig/=-1) prn = PACK( tr(:)%name, MASK=tr(:)%iGeneration == ig) 443 448 lg(:) = [(ANY(prn(:) == tr(iq)%parent), iq=1, nq)] !--- Current generation tracers flag 444 449 IF( ALL( .NOT. lg ) ) EXIT !--- Empty current generation … … 470 475 471 476 !=== CHECK FOR ORPHAN TRACERS 472 IF(test(checkList(tr%name, tr%iGeneration== 0, mesg, 'tracers', 'orphan'), lerr)) RETURN477 IF(test(checkList(tr%name, tr%iGeneration==-1, mesg, 'tracers', 'orphan'), lerr)) RETURN 473 478 474 479 !=== CHECK PHASES 475 DO iq=1,nq; IF(tr(iq)%iGeneration/= 1) CYCLE !--- Generation 1only is checked480 DO iq=1,nq; IF(tr(iq)%iGeneration/=0) CYCLE !--- Generation O only is checked 476 481 pha = fgetKey(iq, 'phases', tr(:)%keys, 'g') !--- Phases 477 482 np = LEN_TRIM(pha); bp(iq)=' ' … … 479 484 IF(TRIM(bp(iq)) /= '') bp(iq) = TRIM(tr(iq)%name)//': '//TRIM(bp(iq)) 480 485 END DO 481 lerr = checkList(bp, tr%iGeneration== 1.AND. bp/='', mesg, 'tracers phases', 'unknown')486 lerr = checkList(bp, tr%iGeneration==0 .AND. bp/='', mesg, 'tracers phases', 'unknown') 482 487 END FUNCTION checkTracers 483 488 !============================================================================================================================== 484 489 485 490 !============================================================================================================================== 486 LOGICAL FUNCTION checkUnique(tr, lTag,sname, fname) RESULT(lerr)491 LOGICAL FUNCTION checkUnique(tr, sname, fname) RESULT(lerr) 487 492 !------------------------------------------------------------------------------------------------------------------------------ 488 493 ! Purpose: Make sure that tracers are not repeated. 489 494 !------------------------------------------------------------------------------------------------------------------------------ 490 495 TYPE(trac_type), INTENT(IN) :: tr(:) !--- Tracer derived type vector 491 LOGICAL, INTENT(IN) :: lTag(:) !--- Tagging tracer flag492 496 CHARACTER(LEN=*), INTENT(IN) :: sname !--- Section name 493 497 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- File name … … 502 506 nq=SIZE(tr,DIM=1); lerr=.FALSE. !--- Number of lines ; error flag 503 507 tdup(:) = '' 504 DO iq=1,nq; IF( lTag(iq)) CYCLE!--- Tags can be repeated508 DO iq=1,nq; IF(tr(iq)%type == 'tag') CYCLE !--- Tags can be repeated 505 509 tnam = TRIM(tr(iq)%name) 506 510 ll = tr(:)%name==TRIM(tnam) !--- Mask for current tracer name … … 585 589 !------------------------------------------------------------------------------------------------------------------------------ 586 590 ! Purpose: Sort tracers: 591 ! * Put water at first places, in the "known_phases" order. 587 592 ! * lGrowGen == T: in ascending generations numbers. 588 593 ! * lGrowGen == F: tracer + its childs sorted by growing generation, one after the other. 594 ! TO BE ADDED IF NECESSARY: HIGHER MOMENTS AT THE END 589 595 !------------------------------------------------------------------------------------------------------------------------------ 590 596 TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector 591 INTEGER :: ig, ng, iq, jq, n, ix(SIZE(tr)), k597 INTEGER :: ig, ng, iq, jq, ip, nq, n, ix(SIZE(tr)), k 592 598 INTEGER, ALLOCATABLE :: iy(:), iz(:) 593 599 !------------------------------------------------------------------------------------------------------------------------------ 600 nq = SIZE(tr) 601 iy = [(k, k=1, nq)] 602 DO ip = nphases, 1, -1 603 iq = strIdx(tracers(:)%name, 'H2O'//phases_sep//known_phases(ip:ip)) 604 IF(iq/=0) iy = [iq, iy(1:iq-1), iy(iq:nq)] 605 END DO 606 tr = tr(iy) !--- Water displaces at first positions 594 607 iq = 1 595 608 IF(lSortByGen) THEN 596 609 ng = MAXVAL(tr(:)%iGeneration, MASK=.TRUE., DIM=1) !--- Number of generations 597 610 DO ig = 0, ng !--- Loop on generations 598 iy = PACK([(k, k=1, SIZE(tr))], MASK=tr(:)%iGeneration==ig)!--- Generation ig tracers indexes611 iy = PACK([(k, k=1, nq)], MASK=tr(:)%iGeneration==ig) !--- Generation ig tracers indexes 599 612 n = SIZE(iy) 600 613 ix(iq:iq+n-1) = iy !--- Stack growing generations idxs … … 602 615 END DO 603 616 ELSE 604 DO jq = 1, SIZE(tr,DIM=1)!--- Loop on first generation tracers617 DO jq = 1, nq !--- Loop on first generation tracers 605 618 IF(tr(jq)%iGeneration /= 1) CYCLE !--- Skip generations >= 1 606 619 ix(iq) = jq !--- First generation ancestor index first … … 727 740 SUBROUTINE setDirectKeys(tr) 728 741 TYPE(trac_type), INTENT(INOUT) :: tr(:) 729 CALL indexUpdate(tr) !--- Update iqParent and iqDescen indexes vectors 742 743 !--- Update %iqParent, %iqDescen, %nqDescen, %nqChilds 744 CALL indexUpdate(tr) 745 746 !--- Extract some direct-access keys 730 747 ! DO iq = 1, SIZE(tr) 731 ! tr(iq)%keys%<key> = getKey_prv(it, "<key>", tr%keys, tran0 ) !--- For additional keys748 ! tr(iq)%keys%<key> = getKey_prv(it, "<key>", tr%keys, <default_value> ) 732 749 ! END DO 733 750 END SUBROUTINE setDirectKeys … … 829 846 !=== NOTES: ==== 830 847 !=== * Most of the "isot" components have been defined in the calling routine (initIsotopes): ==== 831 !=== p rnt, nzon, zone(:), niso, keys(:)%name, nitr, trac(:), npha, phas, iTraPha(:,:), iZonPhi(:,:)====848 !=== parent, nzone, zone(:), niso, keys(:)%name, ntiso, trac(:), nphas, phas, iTraPha(:,:), iZonPhi(:,:) ==== 832 849 !=== * Same syntax for isotopes file and "tracer.def": a tracers section contains one line for each of its isotopes ==== 833 850 !=== * Each tracers section can contain a "params" virtual isotope line of isotopes parameters default values ==== … … 939 956 s%zone = PACK(strTail(t(:)%name,'_',lFirst=.TRUE.), MASK = ll) !--- Tagging zones names for isotopes category "iname" 940 957 CALL strReduce(s%zone) 941 s%nzon = SIZE(s%zone)!--- Tagging zones number for isotopes category "iname"958 s%nzone = SIZE(s%zone) !--- Tagging zones number for isotopes category "iname" 942 959 943 960 !=== Geographic tracers of the isotopes childs of tracer "iname" (same for each phase of "iname") … … 945 962 str = PACK(delPhase(t(:)%name), MASK=ll) 946 963 CALL strReduce(str) 947 s%n itr = s%niso + SIZE(str)!--- Number of isotopes + their geographic tracers [ntraciso]948 ALLOCATE(s%trac(s%n itr))964 s%ntiso = s%niso + SIZE(str) !--- Number of isotopes + their geographic tracers [ntraciso] 965 ALLOCATE(s%trac(s%ntiso)) 949 966 FORALL(it = 1:s%niso) s%trac(it) = s%keys(it)%name 950 FORALL(it = s%niso+1:s%n itr) s%trac(it) = str(it-s%niso)967 FORALL(it = s%niso+1:s%ntiso) s%trac(it) = str(it-s%niso) 951 968 952 969 !=== Phases for tracer "iname" 953 970 s%phase = '' 954 971 DO ip = 1, nphases; ph = known_phases(ip:ip); IF(strIdx(t%name,addPhase(iname, ph)) /= 0) s%phase = TRIM(s%phase)//ph; END DO 955 s%npha = LEN_TRIM(s%phase)!--- Equal to "nqo" for water972 s%nphas = LEN_TRIM(s%phase) !--- Equal to "nqo" for water 956 973 957 974 !=== Tables giving the index in a table of effectively found items for each dynamical tracer (1<=iq<=nqtot) … … 968 985 !=== Table used to get iq (index in dyn array, size nqtot) from the isotope and phase indexes ; the full isotopes list 969 986 ! (including tagging tracers) is sorted this way: iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN 970 s%iTraPha = RESHAPE( [( (strIdx(t(:)%name, addPhase(s%trac(it),s%phase(ip:ip))), it=1, s%n itr), ip=1, s%npha)], &971 [s%n itr, s%npha] )972 973 !=== Table used to get ix (index in tagging tracers isotopes list, size n itr) from the zone and isotope indexes974 s%iZonIso = RESHAPE( [( (strIdx(s%trac(:), TRIM(s%trac(it))//'_'//TRIM(s%zone(iz))), iz=1, s%nzon ), it=1, s%niso)], &975 [s%nzon , s%niso] )987 s%iTraPha = RESHAPE( [( (strIdx(t(:)%name, addPhase(s%trac(it),s%phase(ip:ip))), it=1, s%ntiso), ip=1, s%nphas)], & 988 [s%ntiso, s%nphas] ) 989 990 !=== Table used to get ix (index in tagging tracers isotopes list, size ntiso) from the zone and isotope indexes 991 s%iZonIso = RESHAPE( [( (strIdx(s%trac(:), TRIM(s%trac(it))//'_'//TRIM(s%zone(iz))), iz=1, s%nzone), it=1, s%niso )], & 992 [s%nzone, s%niso] ) 976 993 END DO 977 994 … … 1240 1257 out = s 1241 1258 IF(s == '') RETURN !--- Empty string: nothing to do 1259 1260 !--- Special case: old phases for water, no phases separator 1261 IF(ANY([('H2O'//old_phases(ix:ix), ix=1, nphases)] == s)) THEN; out='H2O'; RETURN; END IF 1262 1242 1263 !--- Index of found phase in "known_phases" 1243 1264 ix = MAXLOC( [(i, i=1,nphases)], MASK=[( INDEX(s, phases_sep//known_phases(i:i))/=0, i=1, nphases)], DIM=1 ) … … 1252 1273 END FUNCTION delPhase 1253 1274 !------------------------------------------------------------------------------------------------------------------------------ 1254 CHARACTER(LEN=maxlen) FUNCTION addPhase_1(s,pha) RESULT(out) 1255 CHARACTER(LEN=*), INTENT(IN) :: s 1256 CHARACTER(LEN=1), INTENT(IN) :: pha 1275 CHARACTER(LEN=maxlen) FUNCTION addPhase_1(s,pha,ph_sep) RESULT(out) 1276 CHARACTER(LEN=*), INTENT(IN) :: s 1277 CHARACTER(LEN=1), INTENT(IN) :: pha 1278 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: ph_sep 1279 CHARACTER(LEN=1) :: psep 1257 1280 INTEGER :: l, i 1258 1281 out = s 1259 1282 IF(s == '') RETURN !--- Empty string: nothing to do 1283 psep = phases_sep; IF(PRESENT(ph_sep)) psep = ph_sep 1260 1284 i = INDEX(s, '_') !--- /=0 for <var>_<tag> tracers names 1261 1285 l = LEN_TRIM(s) 1262 IF(i == 0) out = TRIM(s)// phases_sep//pha !--- <var> => return <var><sep><pha>1263 IF(i /= 0) out = s(1:i-1)// phases_sep//pha//'_'//s(i+1:l) !--- <var>_<tag> => return <var><sep><pha>_<tag>1286 IF(i == 0) out = TRIM(s)//TRIM(psep)//pha !--- <var> => return <var><sep><pha> 1287 IF(i /= 0) out = s(1:i-1)//TRIM(psep)//pha//'_'//s(i+1:l) !--- <var>_<tag> => return <var><sep><pha>_<tag> 1264 1288 END FUNCTION addPhase_1 1265 1289 !------------------------------------------------------------------------------------------------------------------------------ 1266 FUNCTION addPhase_m(s,pha) RESULT(out) 1267 CHARACTER(LEN=*), INTENT(IN) :: s(:) 1268 CHARACTER(LEN=1), INTENT(IN) :: pha 1269 CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) 1290 FUNCTION addPhase_m(s,pha,ph_sep) RESULT(out) 1291 CHARACTER(LEN=*), INTENT(IN) :: s(:) 1292 CHARACTER(LEN=1), INTENT(IN) :: pha 1293 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: ph_sep 1294 CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) 1295 CHARACTER(LEN=1) :: psep 1270 1296 INTEGER :: k 1271 out = [( addPhase_1(s(k), pha), k=1, SIZE(s) )] 1297 psep = phases_sep; IF(PRESENT(ph_sep)) psep = ph_sep 1298 out = [( addPhase_1(s(k), pha, psep), k=1, SIZE(s) )] 1272 1299 END FUNCTION addPhase_m 1273 1300 !------------------------------------------------------------------------------------------------------------------------------ … … 1282 1309 INTEGER, OPTIONAL, INTENT(IN) :: igen 1283 1310 INTEGER :: ig, ix 1284 ig = 1; IF(PRESENT(igen)) ig = igen1311 ig = 0; IF(PRESENT(igen)) ig = igen 1285 1312 ix = idxAncestor_1(t, tname, ig) 1286 1313 out = ''; IF(ix /= 0) out = t(ix)%name … … 1294 1321 INTEGER, ALLOCATABLE :: ix(:) 1295 1322 INTEGER :: ig 1296 ig = 1; IF(PRESENT(igen)) ig = igen1323 ig = 0; IF(PRESENT(igen)) ig = igen 1297 1324 IF( PRESENT(tname)) ix = idxAncestor_m(t, tname, ig) 1298 1325 IF(.NOT.PRESENT(tname)) ix = idxAncestor_m(t, t(:)%name, ig) … … 1307 1334 !============================================================================================================================== 1308 1335 INTEGER FUNCTION idxAncestor_1(t, tname, igen) RESULT(out) 1309 ! Return the name of the generation "igen" ancestor of "tname"1336 ! Return the name of the generation "igen" (>=0) ancestor of "tname" 1310 1337 TYPE(trac_type), INTENT(IN) :: t(:) 1311 1338 CHARACTER(LEN=*), INTENT(IN) :: tname 1312 1339 INTEGER, OPTIONAL, INTENT(IN) :: igen 1313 1340 INTEGER :: ig 1314 ig = 1; IF(PRESENT(igen)) ig = igen1341 ig = 0; IF(PRESENT(igen)) ig = igen 1315 1342 out = strIdx(t(:)%name, tname) 1316 IF(out == 0) RETURN1317 IF(t(out)%iGeneration <= ig) RETURN 1343 IF(out == 0) RETURN !--- Tracer not found 1344 IF(t(out)%iGeneration <= ig) RETURN !--- Tracer has a lower generation number than asked generation 'igen" 1318 1345 DO WHILE(t(out)%iGeneration > ig); out = strIdx(t(:)%name, t(out)%parent); END DO 1319 1346 END FUNCTION idxAncestor_1 … … 1325 1352 INTEGER, OPTIONAL, INTENT(IN) :: igen 1326 1353 INTEGER :: ig, ix 1327 ig = 1; IF(PRESENT(igen)) ig = igen1354 ig = 0; IF(PRESENT(igen)) ig = igen 1328 1355 IF( PRESENT(tname)) out = [(idxAncestor_1(t, tname(ix), ig), ix=1, SIZE(tname))] 1329 1356 IF(.NOT.PRESENT(tname)) out = [(idxAncestor_1(t, t(ix)%name, ig), ix=1, SIZE(t))]
Note: See TracChangeset
for help on using the changeset viewer.
