MODULE readTracFiles_mod USE strings_mod, ONLY: msg, testFile, strFind, strStack, strReduce, strHead, strCount, find, dispTable, fmsg, & removeComment, cat, checkList, strIdx, strParse, strReplace, strTail, reduceExpr, test, modname, get_in USE trac_types_mod, ONLY : tra, iso, db, kys IMPLICIT NONE PRIVATE PUBLIC :: initIsotopes PUBLIC :: readTracersFiles, aliasTracer, tracersSubset, indexUpdate !--- TOOLS ASSOCIATED TO TRACERS DESCRIPTORS PUBLIC :: readIsotopesFile !--- TOOLS ASSOCIATED TO ISOTOPES DESCRIPTORS PUBLIC :: getKey_init, getKey, setDirectKeys !--- FUNCTIONS TO GET KEYS FROM tracers & isotopes PUBLIC :: known_phases, old_phases, nphases, phases_names, phases_sep, &!--- VARIABLES RELATED TO THE PHASES delPhase, addPhase !--- ROUTINES TO ADD/REMOVE PHASE TO/FROM A NAME PUBLIC :: tran0, idxAncestor, ancestor !--- GEN 0 TRACER + TOOLS FOR GENERATIONS !------------------------------------------------------------------------------------------------------------------------------ INTERFACE getKey MODULE PROCEDURE getKeyByName_s1, getKeyByName_i1, getKeyByName_r1, getKeyByName_sm, getKeyByName_im, getKeyByName_rm END INTERFACE getKey !------------------------------------------------------------------------------------------------------------------------------ INTERFACE tracersSubset; MODULE PROCEDURE trSubset_Indx, trSubset_Name, trSubset_Nam1; END INTERFACE tracersSubset INTERFACE idxAncestor; MODULE PROCEDURE idxAncestor_1, idxAncestor_m; END INTERFACE idxAncestor INTERFACE ancestor; MODULE PROCEDURE ancestor_1, ancestor_m; END INTERFACE ancestor INTERFACE addPhase; MODULE PROCEDURE addPhase_1, addPhase_m; END INTERFACE addPhase !------------------------------------------------------------------------------------------------------------------------------ !=== MAIN DATABASE: files sections descriptors TYPE(db), SAVE, ALLOCATABLE, TARGET :: dBase(:) !--- SOME PARAMETERS THAT ARE NOT LIKELY TO CHANGE OFTEN CHARACTER(LEN=256), SAVE :: tran0 = 'air' !--- Default transporting fluid CHARACTER(LEN=256), PARAMETER :: old_phases = 'vli' !--- Old phases for water (no separator) CHARACTER(LEN=256), PARAMETER :: known_phases = 'gls' !--- Known phases initials INTEGER, PARAMETER :: nphases = LEN_TRIM(known_phases) !--- Number of phases CHARACTER(LEN=256), SAVE :: phases_names(nphases) & !--- Known phases names = ['gaseous', 'liquid ', 'solid '] CHARACTER(LEN=1), SAVE :: phases_sep = '_' !--- Phase separator LOGICAL, SAVE :: tracs_merge = .TRUE. !--- Merge/stack tracers lists LOGICAL, SAVE :: lSortByGen = .TRUE. !--- Sort by growing generation !=== LOCAL COPIES OF THE TRACERS AND ISOTOPES DESCRIPTORS, USED BY getKey (INITIALIZED IN getKey_init) TYPE(tra), ALLOCATABLE, TARGET, SAVE :: tracers(:) TYPE(iso), ALLOCATABLE, TARGET, SAVE :: isotopes(:) CONTAINS !============================================================================================================================== !============================================================================================================================== !=== READ ONE OR SEVERAL TRACER FILES AND FILL A "tr" TRACERS DESCRIPTOR DERIVED TYPE. !=== THE RETURN VALUE fType DEPENDS ON WHAT IS FOUND: !=== 0: NO ADEQUATE FILE FOUND ; DEFAULT VALUES MUST BE USED !=== 1: AN "OLD STYLE" TRACERS FILE "traceur.def": !=== First line: Other lines: [] !=== 2: A "NEW STYLE" TRACERS FILE "tracer.def" WITH SEVERAL SECTIONS. !=== 3: SEVERAL " " TRACERS FILES "tracer_.def" WITH A SINGLE SECTION IN EACH. !=== REMARKS: !=== * EACH SECTION BEGINS WITH A "&
LINE !=== * DEFAULT VALUES FOR ALL THE SECTIONS OF THE FILE ARE DEFINED IN THE SPECIAL SECTION "&default" !=== * EACH SECTION LINE HAS THE STRUCTURE: = = ... !=== * SO FAR, THE DEFINED KEYS ARE: parent, phases, hadv, vadv, type !=== * AND CAN BE LISTS OF COMA-SEPARATED TRACERS ; THE ROUTINE EXPAND THESE FACTORIZATIONS. !=== FUNCTION RETURN VALUE "lerr" IS FALSE IN CASE SOMETHING WENT WRONG. !=== ABOUT THE KEYS: ! * The "keys" component (of type kys) is in principle enough to store everything we could need. ! But some variables are stored as direct-access keys to make the code more readable and because they are used often. ! * Most of the direct-access keys are set in this module, but some are not (lnam, iadv and itr for example). ! * Some of the direct-access keys must be updated (using the routine "setDirectKeys") is a subset of "tracers(:)" ! is extracted: the indexes are no longer valid for a subset (examples: tracers(:)iprnt or tracers(:)%ichld). ! * If you need to convert a %key/%val pair into a direct-access key, add the corresponding line in "setDirectKeys". !============================================================================================================================== LOGICAL FUNCTION readTracersFiles(type_trac, fType, tracs) RESULT(lerr) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=*), INTENT(IN) :: type_trac !--- List of components used INTEGER, INTENT(OUT) :: fType !--- Type of input file found TYPE(tra), ALLOCATABLE, INTENT(OUT) :: tracs(:) CHARACTER(LEN=256), ALLOCATABLE :: s(:), sections(:), trac_files(:) CHARACTER(LEN=256) :: str, fname, mesg INTEGER :: is, nsec, ierr, it, ntrac, ns, ip LOGICAL, ALLOCATABLE :: ll(:), lGen3(:) !------------------------------------------------------------------------------------------------------------------------------ lerr = .FALSE. ! modname = 'readTracersFiles' IF(.NOT.ALLOCATED(dBase)) ALLOCATE(dBase(0)) !--- Required sections + corresponding files names (new style single section case) IF(test(strParse(type_trac, ',', sections), lerr)) RETURN !--- Parse "type_trac" list nsec = SIZE(sections, DIM=1) ALLOCATE(trac_files(nsec)); DO is=1, nsec; trac_files(is) = 'tracer_'//TRIM(sections(is))//'.def'; END DO !--- LOOK AT AVAILABLE FILES ll = .NOT.testFile(trac_files) fType = 0 IF(.NOT.testFile('traceur.def') .AND. nsec==1) fType = 1 !--- OLD STYLE FILE IF(.NOT.testFile('tracer.def')) fType = 2 !--- NEW STYLE ; SINGLE FILE, SEVERAL SECTIONS IF(ALL(ll)) fType = 3 !--- NEW STYLE ; SEVERAL FILES, SINGLE SECTION USED IF(ANY(ll) .AND. fType/=3) THEN !--- MISSING FILES IF(test(checkList(trac_files, .NOT.ll, 'Failed reading tracers description', 'files', 'missing'), lerr)) RETURN END IF !--- TELLS WHAT WAS IS ABOUT TO BE USED IF( fmsg(fType==0, 'No adequate tracers description file(s) found ; default values will be used')) RETURN CALL msg(fType==1, 'Trying to read old-style tracers description file "traceur.def"') CALL msg(fType==2, 'Trying to read the new style multi-sections tracers description file "tracer.def"') CALL msg(fType==3, 'Trying to read the new style single section tracers description files "tracer_*.def"') !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(fType==1) THEN !=== OLD FORMAT "traceur.def" !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !--- OPEN THE "traceur.def" FILE OPEN(90, FILE="traceur.def", FORM='formatted', STATUS='old', IOSTAT=ierr) !--- GET THE TRACERS NUMBER READ(90,'(i3)',IOSTAT=ierr)ntrac !--- Number of lines/tracers IF(test(fmsg(ierr /= 0, 'Invalid format for "'//TRIM(fname)//'"'), lerr)) RETURN !--- READ THE REMAINING LINES: [] ALLOCATE(tracs(ntrac)) DO it=1,ntrac !=== READ RAW DATA: loop on the line/tracer number READ(90,'(a)',IOSTAT=ierr) str IF(test(fmsg(ierr>0, 'Invalid format for "' //TRIM(fname)//'"'), lerr)) RETURN IF(test(fmsg(ierr<0, 'Not enough lines in "'//TRIM(fname)//'"'), lerr)) RETURN ll = strParse(str, ' ', s, n=ns) tracs(it)%keys%key = ['hadv', 'vadv'] tracs(it)%keys%val = s(1:2) CALL msg(ns == 3 .AND. it == 1, 'This file is for air tracers only') CALL msg(ns == 4 .AND. it == 1, 'This files specifies the transporting fluid') tracs(it)%name = s(3); tracs(it)%phas = known_phases(1:1) !--- Default: name, gazeous phase "g" DO ip = 1, nphases !--- Deal with old water names IF(s(3) /= 'H2O'//old_phases(ip:ip)) CYCLE tracs(it)%phas = known_phases(ip:ip); tracs(it)%name = 'H2O'//phases_sep//TRIM(tracs(it)%phas) END DO tracs(it)%prnt = tran0 !--- Default transporting fluid: Air IF(ns == 4) tracs(it)%prnt = s(4) !--- Transporting fluid name END DO CLOSE(90) lGen3 = tracs%igen==3 CALL setGeneration(tracs) !--- Determine tracs(:)%igen values IF(test(checkTracers(tracs, fname,fname),lerr)) RETURN !--- Detect orphans and check phases IF(test(checkUnique (tracs,lGen3,fname,fname),lerr)) RETURN !--- Detect repeated tracers CALL sortTracers (tracs) !--- Sort the tracers CALL setDirectKeys(tracs) !--- Set the directly accessible keys tracs(:)%keys%name = tracs(:)%name !--- Copy tracers names in keys components RETURN !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ END IF !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !=== USING NEW FORMAT TRACERS DESCRIPTION FILES WITH POSSIBLY SEVERAL SECTIONS CALL msg(nsec > 1 .AND. tracs_merge, 'The multiple required sections will be MERGED.') CALL msg(nsec > 1 .AND. .NOT.tracs_merge, 'The multiple required sections will be CUMULATED.') !=== FEED THE DATABASE WITH THE RAW CONTENT OF THE FILE SELECT CASE(fType) CASE(2); lerr = feedDBase(["tracer.def"],[type_trac]) !--- Single file, coma-separated sections list CASE(3); lerr = feedDBase(trac_files, sections ) !--- Multiple files, one section name each file END SELECT IF(lerr) RETURN IF( tracs_merge) lerr = mergeTracers(dBase, tracs) !--- MERGE THE COMPONENTS OF THE DATABASE IF(.NOT.tracs_merge) lerr = cumulTracers(dBase, tracs) !--- CUMULATE THE COMPONENTS OF THE DATABASE IF(lerr) RETURN CALL setDirectKeys(tracs) !--- Set the directly accessible keys END FUNCTION readTracersFiles !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION feedDBase(fnames, snames) RESULT(lerr) ! Purpose: Read the sections "snames(is)" (coma-separated list) from each "fnames(is)" ! file and create the corresponding tracers set descriptors in the database "dBase": ! * dBase(id)%name : section name ! * dBase(id)%trac(:)%name : tracers names ! * dBase(id)%trac(it)%keys%key(:): names of keys associated to tracer dBase(id)%trac(it)%name ! * dBase(id)%trac(it)%keys%val(:): values of keys associated to tracer dBase(id)%trac(it)%name !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=*), INTENT(IN) :: fnames(:) !--- Files names CHARACTER(LEN=*), INTENT(IN) :: snames(:) !--- Coma-deparated list of sections (one list each file) INTEGER, ALLOCATABLE :: ndb(:) !--- Nuber of sections for each file INTEGER, ALLOCATABLE :: ixf(:) !--- File index for each section of the expanded list LOGICAL, ALLOCATABLE :: lTg(:) !--- Tagging tracers mask CHARACTER(LEN=256) :: fnm, snm INTEGER :: idb, i LOGICAL :: ll !------------------------------------------------------------------------------------------------------------------------------ !=== READ THE REQUIRED SECTIONS ll = strCount(snames, ',', ndb) !--- Number of sections for each file ALLOCATE(ixf(SUM(ndb))) DO i=1, SIZE(fnames) IF(test(readSections(fnames(i), snames(i), 'default'), lerr)) RETURN ixf(1+SUM(ndb(1:i-1)):SUM(ndb(1:i))) = i !--- File index for each section of the expanded list END DO !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ DO idb=1,SIZE(dBase) !--- LOOP ON THE LOADED SECTIONS !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ fnm = fnames(ixf(idb)); snm = dBase(idb)%name IF(test(expandSection(dBase(idb)%trac, snm, fnm),lerr)) RETURN !--- EXPAND NAMES AND PARENTS LISTS CALL setGeneration (dBase(idb)%trac) !--- DETERMINE GENERATION NUMBER IF(test(checkTracers (dBase(idb)%trac, snm, fnm),lerr)) RETURN !--- CHECK ORPHANS AND PHASES lTg = dBase(idb)%trac(:)%type == 'tag' !--- Flag for tagging tracers IF(test(checkUnique (dBase(idb)%trac,lTg,snm,fnm),lerr)) RETURN !--- CHECK TRACERS UNIQUENESS CALL expandPhases (dBase(idb)%trac) !--- EXPAND THE PHASES CALL sortTracers (dBase(idb)%trac) !--- SORT TRACERS !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ END DO !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !=== DISPLAY BASIC INFORMATION lerr = ANY([(dispTraSection('Expanded list for section "'//TRIM(dBase(idb)%name)//'"',dBase(idb)%name), idb=1, SIZE(dBase))]) END FUNCTION feedDBase !------------------------------------------------------------------------------------------------------------------------------ !------------------------------------------------------------------------------------------------------------------------------ LOGICAL FUNCTION readSections(fnam,snam,defName) RESULT(lerr) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=*), INTENT(IN) :: fnam !--- File name CHARACTER(LEN=*), INTENT(IN) :: snam !--- Coma-separated sections list CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: defName !--- Special section (default values) name !------------------------------------------------------------------------------------------------------------------------------ TYPE(db), ALLOCATABLE :: tdb(:) CHARACTER(LEN=256), ALLOCATABLE :: sec(:) INTEGER, ALLOCATABLE :: ix(:) INTEGER :: n0, idb, ndb, i, j LOGICAL :: ll !------------------------------------------------------------------------------------------------------------------------------ n0 = SIZE(dBase) + 1 !--- Index for next entry in the database CALL readSections_all() !--- Read all the sections of file "fnam" ndb= SIZE(dBase) !--- Current number of sections in the database IF(PRESENT(defName)) THEN !--- Add default values to all the tracers DO idb=n0,ndb; CALL addDefault(dBase(idb)%trac, defName); END DO !--- and remove the virtual tracer "defName" END IF ll = strParse(snam, ',', keys = sec) !--- Requested sections names ix = strIdx(dBase(:)%name, sec(:)) !--- Indexes of requested sections in database IF(test(checkList(sec, ix == 0, 'In file "'//TRIM(fnam)//'"','section(s)', 'missing'), lerr)) RETURN tdb = dBase(:); dBase = [tdb(1:n0-1),tdb(PACK(ix, MASK=ix/=0))] !--- Keep requested sections only CONTAINS !------------------------------------------------------------------------------------------------------------------------------ SUBROUTINE readSections_all() !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=256), ALLOCATABLE :: s(:), v(:) TYPE(tra), ALLOCATABLE :: tt(:) TYPE(tra) :: tmp CHARACTER(LEN=1024) :: str CHARACTER(LEN=256) :: secn INTEGER :: ierr, n !------------------------------------------------------------------------------------------------------------------------------ IF(.NOT.ALLOCATED(dBase)) ALLOCATE(dBase(0)) OPEN(90, FILE=fnam, FORM='formatted', STATUS='old') DO; READ(90,'(a)', IOSTAT=ierr)str IF(ierr /= 0 ) EXIT !--- Finished: error or end of file IF(str(1:1)=='#') CYCLE !--- Skip comments lines CALL removeComment(str) !--- Skip comments at the end of a line IF(str == '') CYCLE !--- Skip empty line (probably at the end of the file) IF(str(1:1)=='&') THEN !=== SECTION HEADER LINE ndb = SIZE(dBase) !--- Number of sections so far secn = str(2:LEN_TRIM(str))//' ' !--- Current section name IF(ANY(dBase(:)%name == secn)) CYCLE !--- Already known section IF(secn(1:7) == 'version') CYCLE !--- Skip the "version" special section ndb = ndb + 1 !--- Extend database ALLOCATE(tdb(ndb)) tdb(1:ndb-1) = dBase tdb(ndb)%name = secn ALLOCATE(tdb(ndb)%trac(0)) CALL MOVE_ALLOC(FROM=tdb, TO=dBase) ELSE !=== TRACER LINE ll = strParse(str,' ', keys = s, vals = v, n = n) !--- Parse = pairs tt = dBase(ndb)%trac(:) tmp%name = s(1); tmp%comp=secn; tmp%keys = kys(s(1), s(2:n), v(2:n)) dBase(ndb)%trac = [tt(:), tmp] DEALLOCATE(tt) ! dBase(ndb)%trac = [dBase(ndb)%trac(:), tra(name=s(1), comp=secn, keys=kys(s(1), s(2:n), v(2:n)))] END IF END DO CLOSE(90) END SUBROUTINE readSections_all !------------------------------------------------------------------------------------------------------------------------------ END FUNCTION readSections !============================================================================================================================== !============================================================================================================================== SUBROUTINE addDefault(t, defName) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: Add the keys from virtual tracer named "defName" (if any) and remove this virtual tracer. !------------------------------------------------------------------------------------------------------------------------------ TYPE(tra), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:) CHARACTER(LEN=*), INTENT(IN) :: defName INTEGER :: jd, it, k TYPE(kys), POINTER :: ky TYPE(tra), ALLOCATABLE :: tt(:) jd = strIdx(t(:)%name, defName) IF(jd == 0) RETURN ky => t(jd)%keys DO k = 1, SIZE(ky%key) !--- Loop on the keys of the tracer named "defName" CALL addKey_m(ky%key(k), ky%val(k), t(:)%keys) !--- Add key to all the tracers (no overwriting) END DO tt = [t(1:jd-1),t(jd+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t) !--- Remove the virtual tracer named "defName" END SUBROUTINE addDefault !============================================================================================================================== !============================================================================================================================== SUBROUTINE subDefault(t, defName, lSubLocal) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: Substitute the keys from virtual tracer named "defName" (if any) and remove this virtual tracer. ! Substitute the keys locally (for the current tracer) if the flag "lSubLocal" is .TRUE. !------------------------------------------------------------------------------------------------------------------------------ TYPE(tra), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:) CHARACTER(LEN=*), INTENT(IN) :: defName LOGICAL, INTENT(IN) :: lSubLocal INTEGER :: i0, it, ik TYPE(kys), POINTER :: k0, ky TYPE(tra), ALLOCATABLE :: tt(:) i0 = strIdx(t(:)%name, defName) IF(i0 == 0) RETURN k0 => t(i0)%keys DO it = 1, SIZE(t); IF(it == i0) CYCLE !--- Loop on the tracers ky => t(it)%keys !--- Substitute in the values of = pairs the keys defined in the virtual tracer "defName" DO ik = 1, SIZE(k0%key); CALL strReplace(ky%val, k0%key(ik), k0%val(ik), .TRUE.); END DO IF(.NOT.lSubLocal) CYCLE !--- Substitute in the values of = pairs the keys defined locally (in the current tracer) DO ik = 1, SIZE(ky%key); CALL strReplace(ky%val, ky%key(ik), ky%val(ik), .TRUE.); END DO END DO tt = [t(1:i0-1),t(i0+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t) !--- Remove the virtual tracer named "defName" END SUBROUTINE subDefault !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION expandSection(tr, sname, fname) RESULT(lerr) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: Expand tracers and parents lists in the tracers descriptor "tra". ! Note: * The following keys are expanded, so are accessible explicitely using "%" operator: "parent" "type". ! * Default values are provided for these keys because they are necessary. !------------------------------------------------------------------------------------------------------------------------------ TYPE(tra), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector CHARACTER(LEN=*), INTENT(IN) :: sname CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname TYPE(tra), ALLOCATABLE :: ttr(:) CHARACTER(LEN=256), ALLOCATABLE :: ta(:), pa(:) CHARACTER(LEN=256) :: msg1 INTEGER :: it, nt, iq, nq, itr, ntr, ipr, npr, i LOGICAL :: ll lerr = .FALSE. nt = SIZE(tr) nq = 0 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ DO it = 1, nt !=== GET TRACERS NB AFTER EXPANSION + NEEDED KEYS (name, parent, type) !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !--- Extract useful keys: parent name, type, component name tr(it)%prnt = fgetKey(it, 'parent', tr(:)%keys, tran0 ) tr(it)%type = fgetKey(it, 'type' , tr(:)%keys, 'tracer') tr(it)%comp = sname !--- Determine the number of tracers and parents ; coherence checking ll = strCount(tr(it)%name, ',', ntr) ll = strCount(tr(it)%prnt, ',', npr) !--- Tagging tracers only can have multiple parents IF(test(npr/=1 .AND. TRIM(tr(it)%type)/='tag', lerr)) THEN msg1 = 'Check section "'//TRIM(sname)//'"' IF(PRESENT(fname)) msg1=TRIM(msg1)//' in file "'//TRIM(fname)//'"' CALL msg(TRIM(msg1)//': "'//TRIM(tr(it)%name)//'" has several parents but is not a tag'); RETURN END IF nq = nq + ntr*npr !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ END DO !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL delKey(['parent','type '], tr) ALLOCATE(ttr(nq)) iq = 1 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ DO it = 1, nt !=== EXPAND TRACERS AND PARENTS NAMES LISTS !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ll = strParse(tr(it)%name, ',', ta, n=ntr) !--- Number of tracers ll = strParse(tr(it)%prnt, ',', pa, n=npr) !--- Number of parents DO ipr=1,npr !--- Loop on parents list elts DO itr=1,ntr !--- Loop on tracers list elts i = iq+itr-1+(ipr-1)*ntr ttr(i)%name = ta(itr); ttr(i)%prnt = pa(ipr) ttr(i)%keys = kys(ta(itr), tr(it)%keys%key, tr(it)%keys%val) END DO END DO ttr(iq:iq+ntr*npr-1)%type = tr(it)%type !--- Duplicating type iq = iq + ntr*npr !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ END DO !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ DEALLOCATE(ta,pa) CALL MOVE_ALLOC(FROM=ttr, TO=tr) END FUNCTION expandSection !============================================================================================================================== !============================================================================================================================== SUBROUTINE setGeneration(tr) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: Determine, for each tracer of "tr(:)": ! * the generation number ! * the first generation ancestor name !------------------------------------------------------------------------------------------------------------------------------ ! Arguments: TYPE(tra), INTENT(INOUT) :: tr(:) !--- Tracer derived type vector !------------------------------------------------------------------------------------------------------------------------------ ! Local variables: INTEGER :: iq, nq, ig LOGICAL, ALLOCATABLE :: lg(:) CHARACTER(LEN=256), ALLOCATABLE :: prn(:) !------------------------------------------------------------------------------------------------------------------------------ tr(:)%igen = 0 !--- error if 0 nq = SIZE(tr, DIM=1) !--- Number of tracers lines lg = tr(:)%prnt == tran0 !--- First generation tracers flag WHERE(lg) tr(:)%igen = 1 !--- First generation tracers !=== Determine generation for each tracer ig=0; prn = [tran0] DO !--- Update current generation flag IF(ig/=0) prn = PACK( tr(:)%name, MASK=tr(:)%igen == ig) lg(:) = [(ANY(prn(:) == tr(iq)%prnt), iq=1, nq)] !--- Current generation tracers flag IF( ALL( .NOT. lg ) ) EXIT !--- Empty current generation ig = ig+1; WHERE(lg) tr(:)%igen = ig END DO tr(:)%nam1 = ancestor(tr) !--- First generation ancestor name END SUBROUTINE setGeneration !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION checkTracers(tr, sname, fname) RESULT(lerr) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: ! * check for orphan tracers (without known parent) ! * check wether the phases are known or not ("g"aseous, "l"iquid or "s"olid so far) !------------------------------------------------------------------------------------------------------------------------------ TYPE(tra), INTENT(IN) :: tr(:) !--- Tracer derived type vector CHARACTER(LEN=*), INTENT(IN) :: sname !--- Section name CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- File name CHARACTER(LEN=256) :: mesg CHARACTER(LEN=256) :: bp(SIZE(tr, DIM=1)), pha !--- Bad phases list, phases of current tracer CHARACTER(LEN=1) :: p INTEGER :: ip, np, iq, nq !------------------------------------------------------------------------------------------------------------------------------ nq = SIZE(tr,DIM=1) !--- Number of tracers lines mesg = 'Check section "'//TRIM(sname)//'"' IF(PRESENT(fname)) mesg=TRIM(mesg)//' in file "'//TRIM(fname)//'"' !=== CHECK FOR ORPHAN TRACERS IF(test(checkList(tr%name, tr%igen==0, mesg, 'tracers', 'orphan'), lerr)) RETURN !=== CHECK PHASES DO iq=1,nq; IF(tr(iq)%igen/=1) CYCLE !--- Generation 1 only is checked pha = fgetKey(iq, 'phases', tr(:)%keys, 'g') !--- Phases np = LEN_TRIM(pha); bp(iq)=' ' DO ip=1,np; p = pha(ip:ip); IF(INDEX(known_phases,p)==0) bp(iq) = TRIM(bp(iq))//p; END DO IF(TRIM(bp(iq)) /= '') bp(iq) = TRIM(tr(iq)%name)//': '//TRIM(bp(iq)) END DO lerr = checkList(bp, tr%igen==1 .AND. bp/='', mesg, 'tracers phases', 'unknown') END FUNCTION checkTracers !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION checkUnique(tr, lTag, sname, fname) RESULT(lerr) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: Make sure that tracers are not repeated. !------------------------------------------------------------------------------------------------------------------------------ TYPE(tra), INTENT(IN) :: tr(:) !--- Tracer derived type vector LOGICAL, INTENT(IN) :: lTag(:) !--- Tagging tracer flag CHARACTER(LEN=*), INTENT(IN) :: sname !--- Section name CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- File name !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: ip, np, iq, nq, k LOGICAL, ALLOCATABLE :: ll(:) CHARACTER(LEN=256) :: mesg, tnam, tdup(SIZE(tr,DIM=1)) CHARACTER(LEN=1) :: p !------------------------------------------------------------------------------------------------------------------------------ mesg = 'Check section "'//TRIM(sname)//'"' IF(PRESENT(fname)) mesg=TRIM(mesg)//' in file "'//TRIM(fname)//'"' nq=SIZE(tr,DIM=1); lerr=.FALSE. !--- Number of lines ; error flag tdup(:) = '' DO iq=1,nq; IF(lTag(iq)) CYCLE !--- Tags can be repeated tnam = tr(iq)%name ll = tr(:)%name==tnam !--- Mask for current tracer name IF(COUNT(ll)==1 ) CYCLE !--- Tracer is not repeated IF(tr(iq)%igen>1) THEN tdup(iq) = tnam !--- gen>1: MUST be unique ELSE DO ip=1,nphases; p=known_phases(ip:ip) !--- Loop on known phases !--- Number of appearances of the current tracer with known phase "p" np = COUNT( PACK( [(INDEX(fgetKey(k, 'phases', tr(:)%keys, 'g'),p), k=1, nq)] /=0 , MASK=ll ) ) IF(np <=1) CYCLE tdup(iq) = TRIM(tdup(iq))//TRIM(phases_names(ip)) IF(ANY(tdup(1:iq-1) == tdup(iq))) tdup(iq)='' !--- Avoid repeating same messages END DO END IF IF(tdup(iq) /= '') tdup(iq)=TRIM(tnam)//' in '//TRIM(tdup(iq))//' phase(s)' END DO lerr = checkList(tdup, tdup/='', mesg, 'tracers', 'duplicated') END FUNCTION checkUnique !============================================================================================================================== !============================================================================================================================== SUBROUTINE expandPhases(tr) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: Expand the phases in the tracers descriptor "tr". !------------------------------------------------------------------------------------------------------------------------------ TYPE(tra), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector !------------------------------------------------------------------------------------------------------------------------------ TYPE(tra), ALLOCATABLE :: ttr(:) INTEGER, ALLOCATABLE :: i0(:) CHARACTER(LEN=256) :: nam, pha, trn INTEGER :: ip, np, iq, jq, nq, it, nt, nc, i, n LOGICAL :: lTg, lEx !------------------------------------------------------------------------------------------------------------------------------ nq = SIZE(tr, DIM=1) nt = 0 DO iq = 1, nq !--- GET THE NUMBER OF TRACERS IF(tr(iq)%igen /= 1) CYCLE nc = COUNT(tr(:)%nam1==tr(iq)%name .AND. tr%igen/=1) !--- Number of childs of tr(iq) tr(iq)%phas = fgetKey(iq, 'phases', tr(:)%keys) !--- Phases list of tr(iq) np = LEN_TRIM(tr(iq)%phas) !--- Number of phases of tr(iq) nt = nt + (1+nc) * np !--- Number of tracers after expansion END DO ALLOCATE(ttr(nt)) it = 1 !--- Current "ttr(:)" index DO iq = 1, nq !--- Loop on "tr(:)" indexes lTg = tr(iq)%type=='tag' !--- Current tracer is a tag i0 = strFind(tr(:)%name, tr(iq)%nam1, n) !--- Indexes of first generation ancestor copies np = SUM( [( LEN_TRIM(tr(i0(i))%phas),i=1,n )],1) !--- Number of phases for current tracer tr(iq) lEx = np>1 !--- Need of a phase suffix IF(lTg) lEx=lEx.AND.tr(iq)%igen>1 !--- No phase suffix for first generation tags DO i=1,n !=== LOOP ON FIRST GENERATION ANCESTORS jq=i0(i) !--- tr(jq): ith copy of 1st gen. ancestor of tr(iq) IF(tr(iq)%igen==1) jq=iq !--- Generation 1: current tracer phases only pha = tr(jq)%phas !--- Phases list for tr(jq) DO ip=1,LEN_TRIM(pha) !=== LOOP ON PHASES LISTS trn=TRIM(tr(iq)%name); nam=trn !--- Tracer name (regular case) IF(lTg) nam = TRIM(tr(iq)%prnt) !--- Parent name (tagging case) IF(lEx) nam = TRIM(nam)//phases_sep//pha(ip:ip) !--- Phase extension needed IF(lTg) nam = TRIM(nam)//'_'//TRIM(trn) !--- _ for tags ttr(it) = tr(iq) !--- Same = pairs ttr(it)%name = nam !--- Name with possibly phase suffix ttr(it)%keys%name = nam !--- Name inside the keys decriptor ttr(it)%phas = pha(ip:ip) !--- Single phase entry IF(lEx.AND.tr(iq)%igen>1) THEN ttr(it)%prnt = TRIM(ttr(it)%prnt)//phases_sep//pha(ip:ip) ttr(it)%nam1 = TRIM(ttr(it)%nam1)//phases_sep//pha(ip:ip) END IF it=it+1 END DO IF(tr(iq)%igen==1) EXIT !--- Break phase loop for gen 1 END DO END DO CALL MOVE_ALLOC(FROM=ttr, TO=tr) CALL delKey(['phases'],tr) !--- Remove few keys entries END SUBROUTINE expandPhases !============================================================================================================================== !============================================================================================================================== SUBROUTINE sortTracers(tr) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: Sort tracers: ! * lGrowGen == T: in ascending generations numbers. ! * lGrowGen == F: tracer + its childs sorted by growing generation, one after the other. !------------------------------------------------------------------------------------------------------------------------------ TYPE(tra), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector INTEGER :: ig, ng, iq, jq, n, ix(SIZE(tr)), k INTEGER, ALLOCATABLE :: iy(:), iz(:) !------------------------------------------------------------------------------------------------------------------------------ iq = 1 IF(lSortByGen) THEN ng = MAXVAL(tr(:)%igen, MASK=.TRUE., DIM=1) !--- Number of generations DO ig = 0, ng !--- Loop on generations iy = PACK([(k, k=1, SIZE(tr))], MASK=tr(:)%igen==ig) !--- Generation ig tracers indexes n = SIZE(iy) ix(iq:iq+n-1) = iy !--- Stack growing generations idxs iq = iq + n END DO ELSE DO jq = 1, SIZE(tr,DIM=1) !--- Loop on first generation tracers IF(tr(jq)%igen /= 1) CYCLE !--- Skip generations >= 1 ix(iq) = jq !--- First generation ancestor index first iq = iq + 1 iy = strFind(tr(:)%nam1, tr(jq)%name) !--- Indexes of "tr(jq)" childs in "tr(:)" ng = MAXVAL(tr(iy)%igen, MASK=.TRUE., DIM=1) !--- Generations number of the "tr(jq)" family DO ig = 2, ng !--- Loop on generations for the tr(jq) family iz = find(tr(iy)%igen, ig, n) !--- Indexes of the tracers "tr(iy(:))" of generation "ig" ix(iq:iq+n-1) = iy(iz) !--- Same indexes in "tr(:)" iq = iq + n END DO END DO END IF tr = tr(ix) !--- Reorder the tracers END SUBROUTINE sortTracers !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION mergeTracers(sections, tr) RESULT(lerr) TYPE(db), TARGET, INTENT(IN) :: sections(:) TYPE(tra), ALLOCATABLE, INTENT(OUT) :: tr(:) TYPE(tra), POINTER :: t1(:), t2(:) INTEGER, ALLOCATABLE :: ixct(:), ixck(:) INTEGER :: is, k1, k2, nk2, i1, i2, nt2 CHARACTER(LEN=256) :: s1, v1, v2, tnam, knam lerr = .FALSE. t1 => sections(1)%trac(:) !--- Alias: first tracers section tr = t1 !---------------------------------------------------------------------------------------------------------------------------- DO is=2,SIZE(sections) !=== SEVERAL SECTIONS: MERGE THEM !---------------------------------------------------------------------------------------------------------------------------- t2 => sections(is)%trac(:) !--- Alias: current tracers section nt2 = SIZE(t2(:), DIM=1) !--- Number of tracers in section ixct = strIdx(t1(:)%name, t2(:)%name) !--- Indexes of common tracers tr = [tr, PACK(t2, MASK= ixct==0)] !--- Append with new tracers IF( ALL(ixct == 0) ) CYCLE !--- No common tracers => done CALL msg('Tracers defined in previous sections and duplicated in "'//TRIM(sections(is)%name)//'":') CALL msg( t1(PACK(ixct, MASK = ixct/=0))%name, nmax=128 ) !--- Display duplicates (the 128 first at most) !-------------------------------------------------------------------------------------------------------------------------- DO i2=1,nt2; tnam = t2(i2)%name !=== LOOP ON COMMON TRACERS !-------------------------------------------------------------------------------------------------------------------------- i1 = ixct(i2); IF(i1 == 0) CYCLE !--- Idx in t1(:) ; skip new tracers !=== CHECK WETHER ESSENTIAL KEYS ARE IDENTICAL OR NOT s1=' of "'//TRIM(tnam)//'" in "'//TRIM(sections(is)%name)//'" not matching previous value' IF(test(fmsg(t1(i1)%prnt /= t2(i2)%prnt, 'Parent name'//TRIM(s1)), lerr)) RETURN IF(test(fmsg(t1(i1)%type /= t2(i2)%type, 'Type' //TRIM(s1)), lerr)) RETURN IF(test(fmsg(t1(i1)%igen /= t2(i2)%igen, 'Generation' //TRIM(s1)), lerr)) RETURN !=== APPEND = PAIRS NOT PREVIOULSLY DEFINED nk2 = SIZE(t2(i2)%keys%key(:)) !--- Keys number in current section ixck = strIdx(t1(i1)%keys%key(:), t2(i2)%keys%key(:)) !--- Common keys indexes !=== APPEND NEW KEYS tr(i1)%keys%key = [ tr(i1)%keys%key, PACK(tr(i2)%keys%key, MASK = ixck==0)] tr(i1)%keys%val = [ tr(i1)%keys%val, PACK(tr(i2)%keys%val, MASK = ixck==0)] !--- KEEP TRACK OF THE COMPONENTS NAMES tr(i1)%comp = TRIM(tr(i1)%comp)//','//TRIM(tr(i2)%comp) !--- SELECT COMMON TRACERS WITH DIFFERING KEYS VALUES (PREVIOUS VALUE IS KEPT) DO k2=1,nk2 k1 = ixck(k2); IF(k1 == 0) CYCLE IF(t1(i1)%keys%val(k1) == t2(i2)%keys%val(k2)) ixck(k2)=0 END DO IF(ALL(ixck==0)) CYCLE !--- No identical keys with /=values !--- DISPLAY INFORMATION: OLD VALUES ARE KEPT FOR THE KEYS FOUND IN PREVIOUS AND CURRENT SECTIONS CALL msg('Key(s)'//TRIM(s1)) DO k2 = 1, nk2 !--- Loop on keys found in both t1(:) and t2(:) knam = t2(i2)%keys%key(k2) !--- Name of the current key k1 = ixck(k2) !--- Corresponding index in t1(:) IF(k1 == 0) CYCLE !--- New keys are skipped v1 = t1(i1)%keys%val(k1); v2 = t2(i2)%keys%val(k2) !--- Key values in t1(:) and t2(:) CALL msg(' * '//TRIM(knam)//'='//TRIM(v2)//' ; previous value kept:'//TRIM(v1)) END DO !------------------------------------------------------------------------------------------------------------------------ END DO !-------------------------------------------------------------------------------------------------------------------------- END DO CALL sortTracers(tr) END FUNCTION mergeTracers !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION cumulTracers(sections, tr) RESULT(lerr) TYPE(db), TARGET, INTENT(IN) :: sections(:) TYPE(tra), ALLOCATABLE, INTENT(OUT) :: tr(:) TYPE(tra), POINTER :: t1(:), t2(:) INTEGER, ALLOCATABLE :: nt(:) CHARACTER(LEN=256) :: tnam, tnam_new INTEGER :: iq, nq, is, ns, nsec lerr = .FALSE. !--- Can't fail ; kept to match "mergeTracer" interface. nsec = SIZE(sections) tr = [( sections(is)%trac(:) , is=1, nsec )] !--- Concatenated tracers vector nt = [( SIZE(sections(is)%trac(:)), is=1, nsec )] !--- Number of tracers in each section !---------------------------------------------------------------------------------------------------------------------------- DO is=1, nsec !=== LOOP ON SECTIONS !---------------------------------------------------------------------------------------------------------------------------- t1 => sections(is)%trac(:) !-------------------------------------------------------------------------------------------------------------------------- DO iq=1, nt(is) !=== LOOP ON TRACERS !-------------------------------------------------------------------------------------------------------------------------- tnam = t1(iq)%name !--- Original name IF(COUNT(t1%name == tnam) == 1) CYCLE !--- Current tracer is not duplicated: finished tnam_new = TRIM(tnam)//phases_sep//TRIM(sections(is)%name) !--- Same with section extension nq = SUM(nt(1:is-1)) !--- Number of tracers in previous sections ns = nt(is) !--- Number of tracers in the current section tr(iq + nq)%name = tnam_new !--- Modify tracer name WHERE(tr(1+nq:ns+nq)%prnt==tnam) tr(1+nq:ns+nq)%prnt=tnam_new !--- Modify parent name !-------------------------------------------------------------------------------------------------------------------------- END DO !---------------------------------------------------------------------------------------------------------------------------- END DO !---------------------------------------------------------------------------------------------------------------------------- CALL sortTracers(tr) END FUNCTION cumulTracers !============================================================================================================================== !============================================================================================================================== SUBROUTINE setDirectKeys(tr) TYPE(tra), INTENT(INOUT) :: tr(:) CALL indexUpdate(tr) !--- Update iparnt and idesc indexes vectors ! DO iq = 1, SIZE(tr) ! tr(iq)%keys% = getKey_prv(it, "", tr%keys, tran0 ) !--- For additional keys ! END DO END SUBROUTINE setDirectKeys !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION dispTraSection(message, sname) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: message CHARACTER(LEN=*), INTENT(IN) :: sname INTEGER :: idb, iq, nq INTEGER, ALLOCATABLE :: hadv(:), vadv(:) TYPE(tra), POINTER :: tm(:) lerr = .FALSE. idb = strIdx(dBase(:)%name, sname); IF(idb == 0) RETURN tm => dBase(idb)%trac nq = SIZE(tm) IF(test(getKeyByName_im('hadv', hadv, tm(:)%name, tm(:)%keys),lerr)) RETURN IF(test(getKeyByName_im('vadv', vadv, tm(:)%name, tm(:)%keys),lerr)) RETURN CALL msg(TRIM(message)//':') IF(test(dispTable('iiissis', ['iq ','hadv ','vadv ','short name','parent ','igen ','phase '], & cat(tm(:)%name, tm(:)%prnt, tm(:)%phas), cat([(iq, iq=1, nq)], hadv, vadv, tm(:)%igen)), lerr)) RETURN END FUNCTION dispTraSection !============================================================================================================================== !============================================================================================================================== !============================================================================================================================== !== CREATE A SCALAR ALIAS OF THE COMPONENT OF THE TRACERS DESCRIPTOR "t" NAMED "tname" ======================================== !============================================================================================================================== FUNCTION aliasTracer(tname, t) RESULT(out) TYPE(tra), POINTER :: out CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(tra), TARGET, INTENT(IN) :: t(:) INTEGER :: it it = strIdx(t(:)%name, tname) out => NULL(); IF(it /= 0) out => t(it) END FUNCTION aliasTracer !------------------------------------------------------------------------------------------------------------------------------ !============================================================================================================================== !=== FROM A LIST OF INDEXES OR NAMES, CREATE A SUBSET OF THE TRACERS DESCRIPTORS LIST "trac" ================================== !============================================================================================================================== FUNCTION trSubset_Indx(trac,idx) RESULT(out) TYPE(tra), ALLOCATABLE :: out(:) TYPE(tra), ALLOCATABLE, INTENT(IN) :: trac(:) INTEGER, INTENT(IN) :: idx(:) out = trac(idx) CALL indexUpdate(out) END FUNCTION trSubset_Indx !------------------------------------------------------------------------------------------------------------------------------ FUNCTION trSubset_Name(trac,nam) RESULT(out) TYPE(tra), ALLOCATABLE :: out(:) TYPE(tra), ALLOCATABLE, INTENT(IN) :: trac(:) CHARACTER(LEN=*), INTENT(IN) :: nam(:) out = trac(strIdx(trac(:)%name, nam)) CALL indexUpdate(out) END FUNCTION trSubset_Name !------------------------------------------------------------------------------------------------------------------------------ !============================================================================================================================== !=== CREATE THE SUBSET OF THE TRACERS DESCRIPTORS LIST "trac" HAVING THE FIRST GENERATION ANCESTOR NAMED "nam" ================ !============================================================================================================================== FUNCTION trSubset_Nam1(trac,nam) RESULT(out) TYPE(tra), ALLOCATABLE :: out(:) TYPE(tra), ALLOCATABLE, INTENT(IN) :: trac(:) CHARACTER(LEN=*), INTENT(IN) :: nam out = trac(strFind(delPhase(trac(:)%nam1), nam)) CALL indexUpdate(out) END FUNCTION trSubset_Nam1 !------------------------------------------------------------------------------------------------------------------------------ !============================================================================================================================== !=== UPDATE THE INDEXES iparnt(:), idesc=(:) AND igen(:) IN THE TRACERS DESCRIPTOR LIST "tr" (USEFULL FOR SUBSETS) ============ !============================================================================================================================== SUBROUTINE indexUpdate(tr) TYPE(tra), INTENT(INOUT) :: tr(:) INTEGER :: iq, ig, ng, ngen INTEGER, ALLOCATABLE :: ix(:) tr(:)%iprnt = strIdx( tr(:)%name, tr(:)%prnt ) !--- Parent index ngen = MAXVAL(tr(:)%igen, MASK=.TRUE.) DO iq = 1, SIZE(tr) ng = tr(iq)%igen !--- Generation of the current tracer ix = idxAncestor(tr, igen = ng); ix = PACK(ix, ix/=0) !--- Indexes of the tracers with ancestor tr(iq) !--- Childs indexes in growing generation order tr(iq)%idesc = [( PACK(ix, MASK = tr(ix)%igen == ig), ig = ng+1, ngen)] tr(iq)%ndesc = SUM( [( COUNT(tr(ix)%igen == ig), ig = ng+1, ngen)] ) tr(iq)%nchld = COUNT(tr(ix)%igen == ng+1) END DO END SUBROUTINE indexUpdate !------------------------------------------------------------------------------------------------------------------------------ !============================================================================================================================== !=== READ FILE "fnam" TO APPEND THE "dBase" TRACERS DATABASE WITH AS MUCH SECTIONS AS PARENTS NAMES IN "isot(:)%prnt": ==== !=== * Each section dBase(i)%name contains the isotopes "dBase(i)%trac(:)" descending on "dBase(i)%name"="iso(i)%prnt" ==== !=== * For each isotopes class, the = vector of each tracer is moved into the isotopes descriptor "isot" ==== !=== NOTES: ==== !=== * Most of the "isot" components have been defined in the calling routine (initIsotopes): ==== !=== prnt, nzon, zone(:), niso, keys(:)%name, nitr, trac(:), npha, phas, iTraPha(:,:), iZonPhi(:,:) ==== !=== * Same syntax for isotopes file and "tracer.def": a tracers section contains one line for each of its isotopes ==== !=== * Each tracers section can contain a "params" virtual isotope line of isotopes parameters default values ==== !=== * In case keys are found both in the "params" section and the "*.def" file, the later value is retained ==== !=== * On each isotope line, defined keys can be used for other keys defintions (single level depth substitution) ==== !=== * The routine gives an error if a required isotope is not available in the database stored in "fnam" ==== !============================================================================================================================== LOGICAL FUNCTION readIsotopesFile(fnam, isot) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: fnam !--- Input file name TYPE(iso), TARGET, INTENT(INOUT) :: isot(:) !--- Isotopes descriptors (field "prnt" must be defined !) INTEGER :: ik, is, it, idb, nk0, i, iis INTEGER :: nk, ns, nt, ndb, nb0, i0 CHARACTER(LEN=256), POINTER :: k(:), v(:), k0(:), v0(:) CHARACTER(LEN=256), ALLOCATABLE :: vals(:) CHARACTER(LEN=256) :: val TYPE(kys), POINTER :: ky(:) TYPE(tra), POINTER :: tt(:), t TYPE(db), ALLOCATABLE :: tdb(:) LOGICAL, ALLOCATABLE :: liso(:) !--- THE INPUT FILE MUST BE PRESENT IF(test(fmsg(testFile(fnam),'Missing isotopes parameters file "'//TRIM(fnam)//'"'),lerr)) RETURN !--- READ THE FILE SECTIONS, ONE EACH PARENT TRACER nb0 = SIZE(dBase, DIM=1)+1 !--- Next database element index IF(test(readSections(fnam,strStack(isot(:)%prnt,',')),lerr)) RETURN!--- Read sections, one each parent tracer ndb = SIZE(dBase, DIM=1) !--- Current database size DO idb = nb0, ndb iis = idb-nb0+1 !--- GET FEW GLOBAL KEYS FROM "def" FILES AND ADD THEM TO THE 'params' SECTION CALL addKeysFromDef(dBase(idb)%trac, 'params') !--- SUBSTITUTE THE KEYS DEFINED IN THE 'params' VIRTUAL TRACER ; SUBSTITUTE LOCAL KEYS ; REMOVE 'params' VIRTUAL TRACER CALL subDefault(dBase(idb)%trac, 'params', .TRUE.) tt => dBase(idb)%trac !--- REDUCE THE EXPRESSIONS TO OBTAIN SCALARS AND TRANSFER THEM TO THE "isot" ISOTOPES DESCRIPTORS VECTOR DO it = 1, SIZE(dBase(idb)%trac) t => dBase(idb)%trac(it) is = strIdx(isot(iis)%keys(:)%name, t%name) !--- Index in "isot(iis)%keys(:)%name" of isotope "t%name" IF(is == 0) CYCLE liso = reduceExpr(t%keys%val, vals) !--- Reduce expressions (for substituted variables) IF(test(ANY(liso), lerr)) RETURN !--- Some non-numerical elements were found isot(iis)%keys(is)%key = PACK(t%keys%key, MASK=.NOT.liso) isot(iis)%keys(is)%val = PACK( vals, MASK=.NOT.liso) END DO !--- CHECK FOR MISSING ISOTOPES (NO KEYS ALLOCATED) liso = [( ALLOCATED(isot(iis)%keys(is)%key), is=1, SIZE(isot(iis)%keys) )] IF(test(checkList(isot(iis)%keys(:)%name, .NOT.liso, & 'Check file "'//TRIM(fnam)//'" in section "'//TRIM(dBase(idb)%name)//'"', 'isotopes', 'missing'),lerr)) RETURN END DO !--- CLEAN THE DATABASE ENTRIES IF(nb0 == 1) THEN DEALLOCATE(dBase); ALLOCATE(dBase(0)) ELSE ALLOCATE(tdb(nb0-1)); tdb(1:nb0-1)=dBase(1:nb0-1); CALL MOVE_ALLOC(FROM=tdb, TO=dBase) END IF lerr = dispIsotopes(isot, 'Isotopes parameters read from file') END FUNCTION readIsotopesFile !============================================================================================================================== !============================================================================================================================== !=== IF ISOTOPES (2ND GENERATION TRACERS) ARE DETECTED: === !=== * COMPUTE MOST OF THE RELATED QUANTITIES ("isot" COMPONENTS). === !=== * COMPUTE FEW ISOTOPES-DEDICATED "trac" COMPONENTS === !=== * CALL readIsotopesFile TO GET PHYSICAL QUANTITIES (= PAIRS) === !=== NOTE: THIS IS DONE HERE (IN A ROUTINE CALLED BY THE DYNAMIC), BECAUSE THE DYNAMIC NEEDS FEW PHYSICAL PARAMETERS. === !============================================================================================================================== SUBROUTINE initIsotopes(trac, isot) TYPE(tra), ALLOCATABLE, TARGET, INTENT(INOUT) :: trac(:) TYPE(iso), ALLOCATABLE, TARGET, INTENT(INOUT) :: isot(:) CHARACTER(LEN=256), ALLOCATABLE :: p(:), str(:) !--- Temporary storage CHARACTER(LEN=256) :: iname CHARACTER(LEN=1) :: ph !--- Phase INTEGER :: nbIso, ic, ip, iq, it, iz LOGICAL, ALLOCATABLE :: ll(:) !--- Mask TYPE(tra), POINTER :: t(:), t1 TYPE(iso), POINTER :: s t => trac p = PACK(delPhase(t%prnt), MASK = t%type=='tracer' .AND. t%igen==2)!--- Parents of 2nd generation isotopes CALL strReduce(p, nbIso) ALLOCATE(isot(nbIso)) IF(nbIso==0) RETURN !=== NO ISOTOPES: FINISHED !--- ISOTOPES RELATED VARIABLES ; NULL OR EMPTY IF NO ISOTOPES isot(:)%prnt = p DO ic = 1, SIZE(p) !--- Loop on isotopes classes s => isot(ic) iname = s%prnt !--- Current isotopes class name (parent tracer name) !=== Isotopes childs of tracer "iname": mask, names, number (same for each phase of "iname") ll = t(:)%type=='tracer' .AND. delPhase(t(:)%prnt) == iname .AND. t(:)%phas == 'g' str = PACK(delPhase(t(:)%name), MASK = ll) !--- Effectively found isotopes of "iname" s%niso = SIZE(str) !--- Number of "effectively found isotopes of "iname" ALLOCATE(s%keys(s%niso)) FORALL(it = 1:s%niso) s%keys(it)%name = str(it) !=== Geographic tagging tracers descending on tracer "iname": mask, names, number ll = t(:)%type=='tag' .AND. delPhase(t(:)%nam1) == iname .AND. t(:)%igen == 3 s%zone = PACK(strTail(t(:)%name,'_',lFirst=.TRUE.), MASK = ll) !--- Tagging zones names for isotopes category "iname" CALL strReduce(s%zone) s%nzon = SIZE(s%zone) !--- Tagging zones number for isotopes category "iname" !=== Geographic tracers of the isotopes childs of tracer "iname" (same for each phase of "iname") ! NOTE: One might like to create a similar variable for 2nd generation tagging tracers (tagging the gen1 tracers) str = PACK(delPhase(t(:)%name), MASK=ll) CALL strReduce(str) s%nitr = s%niso + SIZE(str) !--- Number of isotopes + their geographic tracers [ntraciso] ALLOCATE(s%trac(s%nitr)) FORALL(it = 1:s%niso) s%trac(it) = s%keys(it)%name FORALL(it = s%niso+1:s%nitr) s%trac(it) = str(it-s%niso) !=== Phases for tracer "iname" s%phas = '' DO ip = 1, nphases; ph = known_phases(ip:ip); IF(strIdx(t%name,addPhase(iname, ph)) /= 0) s%phas = TRIM(s%phas)//ph; END DO s%npha = LEN_TRIM(s%phas) !--- Equal to "nqo" for water !=== Tables giving the index in a table of effectively found items for each dynamical tracer (1<=iq<=nqtot) DO iq = 1, SIZE(t) t1 => trac(iq) IF(delPhase(t1%nam1) /= iname) CYCLE !--- Only deal with tracers descending on "iname" t1%iso_igr = ic !--- Isotopes family idx in list "isotopes(:)%prnt" t1%iso_num = strIdx(s%trac, delPhase(strHead(t1%name,'_'))) !--- Current isotope idx in effective isotopes list t1%iso_zon = strIdx(s%zone, strTail(t1%name,'_') ) !--- Current isotope zone idx in effective zones list t1%iso_pha = INDEX(s%phas,TRIM(t1%phas)) !--- Current isotope phase idx in effective phases list IF(t1%igen /= 3) t1%iso_zon = 0 !--- Skip possible generation 2 tagging tracers END DO !=== Table used to get iq (index in dyn array, size nqtot) from the isotope and phase indexes ; the full isotopes list ! (including tagging tracers) is sorted this way: iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN s%iTraPha = RESHAPE( [( (strIdx(t(:)%name, addPhase(s%trac(it),s%phas(ip:ip))), it=1, s%nitr), ip=1, s%npha)], & [s%nitr, s%npha] ) !=== Table used to get ix (index in tagging tracers isotopes list, size nitr) from the zone and isotope indexes s%iZonIso = RESHAPE( [( (strIdx(s%trac(:), TRIM(s%trac(it))//'_'//TRIM(s%zone(iz))), iz=1, s%nzon), it=1, s%niso)], & [s%nzon, s%niso] ) END DO !=== Indexes, in dynamical tracers list, of the tracers transmitted to phytrac (nqtottr non-vanishing elements) ll = delPhase(t%name)/='H2O' .AND. t%iso_num ==0 !--- Mask of tracers passed to the physics t(:)%itr = UNPACK([(iq,iq=1,COUNT(ll))], ll, [(0, iq=1, SIZE(t))]) !=== READ PHYSICAL PARAMETERS FROM "isotopes_params.def" FILE ! DONE HERE, AND NOT ONLY IN "infotrac_phy", BECAUSE SOME PHYSICAL PARAMS ARE NEEDED FOR RESTARTS (tnat AND alpha_ideal) IF(readIsotopesFile('isotopes_params.def',isot)) CALL abort_gcm(modname,'Problem when reading isotopes parameters',1) END SUBROUTINE initIsotopes !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION dispIsotopes(ides, message) RESULT(lerr) TYPE(iso), INTENT(IN) :: ides(:) !--- Isotopes descriptor vector CHARACTER(LEN=*), INTENT(IN) :: message !--- Message to display INTEGER :: ik, nk, ip, it, nt CHARACTER(LEN=256) :: prf CHARACTER(LEN=256), ALLOCATABLE :: ttl(:), val(:,:) CALL msg(TRIM(message)//':') DO ip = 1, SIZE(ides) !--- Loop on parents tracers nk = SIZE(ides(ip)%keys(1)%key) !--- Same keys for each isotope nt = SIZE(ides(ip)%keys) !--- Number of isotopes prf = 'i'//REPEAT('s',nk+1) !--- Profile for table printing ALLOCATE(ttl(nk+2), val(nt,nk+1)) ttl(1:2) = ['iq ','name']; ttl(3:nk+2) = ides(ip)%keys(1)%key(:)!--- Titles line with keys names val(:,1) = ides(ip)%keys(:)%name !--- Values table 1st column: isotopes names DO ik = 1, nk DO it = 1, nt val(it,ik+1) = ides(ip)%keys(it)%val(ik) !--- Other columns: keys values END DO END DO IF(test(fmsg(dispTable(prf, ttl, val, cat([(it,it=1,nt)]), rFmt='(EN8.4)'),'Problem with the table content'), lerr)) RETURN DEALLOCATE(ttl, val) END DO END FUNCTION dispIsotopes !============================================================================================================================== !============================================================================================================================== SUBROUTINE addKey_1(key, val, ky, lOverWrite) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: Add the = pair in the "ky" keys descriptor. !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=*), INTENT(IN) :: key, val TYPE(kys), INTENT(INOUT) :: ky LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite CHARACTER(LEN=256), ALLOCATABLE :: k(:), v(:) INTEGER :: iky, nky LOGICAL :: lo !------------------------------------------------------------------------------------------------------------------------------ lo=.FALSE.; IF(PRESENT(lOverWrite)) lo=lOverWrite iky = strIdx(ky%key,key) IF(iky == 0) THEN nky = SIZE(ky%key) IF(nky == 0) THEN; ky%key = [key]; ky%val = [val]; ELSE; ky%key = [ky%key, key]; ky%val = [ky%val, val]; END IF ELSE IF(lo) THEN !--- Overwriting ky%key(iky) = key; ky%val(iky) = val END IF END SUBROUTINE addKey_1 !============================================================================================================================== SUBROUTINE addKey_m(key, val, ky, lOverWrite) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: Add the = pair in all the components of the "ky" keys descriptor. !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=*), INTENT(IN) :: key, val TYPE(kys), INTENT(INOUT) :: ky(:) LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite INTEGER :: itr LOGICAL :: lo !------------------------------------------------------------------------------------------------------------------------------ lo=.FALSE.; IF(PRESENT(lOverWrite)) lo=lOverWrite DO itr = 1, SIZE(ky); CALL addKey_1(key, val, ky(itr), lo); END DO END SUBROUTINE addKey_m !============================================================================================================================== SUBROUTINE addKeysFromDef(t, tr0) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: The values of the keys of the tracer named "tr0" are overwritten by the values found in the *.def files, if any. !------------------------------------------------------------------------------------------------------------------------------ TYPE(tra), ALLOCATABLE, INTENT(INOUT) :: t(:) CHARACTER(LEN=*), INTENT(IN) :: tr0 CHARACTER(LEN=256) :: val INTEGER :: ik, jd jd = strIdx(t%name, tr0) IF(jd == 0) RETURN DO ik = 1, SIZE(t(jd)%keys%key) CALL get_in(t(jd)%keys%key(ik), val, 'zzzz') IF(val /= 'zzzz') CALL addKey_1(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.) END DO END SUBROUTINE addKeysFromDef !============================================================================================================================== SUBROUTINE delKey_1(itr, keyn, ky) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: Internal routine. ! Remove = pairs in the "itr"th component of the "ky" keys descriptor. !------------------------------------------------------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: itr CHARACTER(LEN=*), INTENT(IN) :: keyn(:) TYPE(tra), INTENT(INOUT) :: ky(:) CHARACTER(LEN=256), ALLOCATABLE :: k(:), v(:) LOGICAL, ALLOCATABLE :: ll(:) INTEGER :: iky !------------------------------------------------------------------------------------------------------------------------------ IF(itr<=0 .OR. itr>SIZE(ky, DIM=1)) RETURN !--- Index is out of range ll = [( ALL(keyn/=ky(itr)%keys%key(iky)), iky=1, SIZE(ky(itr)%keys%key) )] k = PACK(ky(itr)%keys%key, MASK=ll); CALL MOVE_ALLOC(FROM=k, TO=ky(itr)%keys%key) v = PACK(ky(itr)%keys%val, MASK=ll); CALL MOVE_ALLOC(FROM=v, TO=ky(itr)%keys%val) END SUBROUTINE delKey_1 !============================================================================================================================== SUBROUTINE delKey(keyn, ky) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: Internal routine. ! Remove = pairs in all the components of the "t" tracers descriptor. !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=*), INTENT(IN) :: keyn(:) TYPE(tra), INTENT(INOUT) :: ky(:) INTEGER :: iky !------------------------------------------------------------------------------------------------------------------------------ DO iky = 1, SIZE(ky); CALL delKey_1(iky, keyn, ky); END DO END SUBROUTINE delKey !============================================================================================================================== !============================================================================================================================== !=== PUBLIC ROUTINES: GET A KEY FROM A = LIST ; VECTORS, TRACER AND DATABASE VERSIONS =============================== !=== BEWARE !!! IF THE "ky" ARGUMENT IS NOT PRESENT, THEN THE VARIABLES "tracers" AND "isotopes" ARE USED. ==================== !=== THEY ARE LOCAL TO THIS MODULE, SO MUST MUST BE INITIALIZED FIRST USING the "getKey_init" ROUTINE ==================== !============================================================================================================================== SUBROUTINE getKey_init(tracers_, isotopes_) TYPE(tra), OPTIONAL, INTENT(IN) :: tracers_(:) TYPE(iso), OPTIONAL, INTENT(IN) :: isotopes_(:) IF(PRESENT( tracers_)) tracers = tracers_ IF(PRESENT(isotopes_)) isotopes = isotopes_ END SUBROUTINE getKey_init !============================================================================================================================== CHARACTER(LEN=256) FUNCTION fgetKey(itr, keyn, ky, def_val) RESULT(out) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: Internal function ; get a key value in string format (this is the returned argument). !------------------------------------------------------------------------------------------------------------------------------ INTEGER, INTENT(IN) :: itr CHARACTER(LEN=*), INTENT(IN) :: keyn TYPE(kys), INTENT(IN) :: ky(:) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def_val !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: ik ik = 0; IF(itr>0 .AND. itr<=SIZE(ky)) ik = strIdx(ky(itr)%key(:), keyn) out = ''; IF(ik /= 0) out = ky(itr)%val(ik) !--- Key was found IF(PRESENT(def_val) .AND. ik == 0) out = def_val !--- Default value from arguments END FUNCTION fgetKey !============================================================================================================================== LOGICAL FUNCTION getKeyByName_s1(keyn, val, tname, ky) RESULT(lerr) !--- Purpose: Get the value of the key named "keyn" for the tracer named "tnam". ! * "ky" unspecified: try in "tracers" for "tnam" with phase and tagging suffixes, then in "isotopes" without. ! * "ky" specified: try in "ky" for "tnam" with phase and tagging suffixes, then without. ! The returned error code is always .FALSE.: an empty string is returned when the key hasn't been found. CHARACTER(LEN=*), INTENT(IN) :: keyn CHARACTER(LEN=256), INTENT(OUT) :: val CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(kys), OPTIONAL, INTENT(IN) :: ky(:) INTEGER :: is lerr = .FALSE. IF(PRESENT(ky)) THEN val = getKeyByName_prv(keyn, tname , ky); IF(val /= '') RETURN !--- "ky" and "tnam" val = getKeyByName_prv(keyn, delPhase(strHead(tname,'_')), ky) !--- "ky" and "tnam" without phase ELSE IF(.NOT.ALLOCATED(tracers)) RETURN val = getKeyByName_prv(keyn, tname, tracers(:)%keys); IF(val /= '') RETURN !--- "tracers" and "tnam" IF(.NOT.ALLOCATED(isotopes)) RETURN IF(SIZE(isotopes) == 0) RETURN DO is = 1, SIZE(isotopes); IF(strIdx(isotopes(is)%keys(:)%name, delPhase(strHead(tname,'_'))) /= 0) EXIT; END DO IF(is /= 0) val = getKeyByName_prv(keyn, tname, isotopes(is)%keys(:)) !--- "isotopes" and "tnam" without phase END IF CONTAINS FUNCTION getKeyByName_prv(keyn, tname, ky) RESULT(val) CHARACTER(LEN=256) :: val CHARACTER(LEN=*), INTENT(IN) :: keyn CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(kys), INTENT(IN) :: ky(:) INTEGER :: itr, iky val = ''; iky = 0 itr = strIdx(ky(:)%name, tname); IF(itr==0) RETURN !--- Get the index of the wanted tracer IF(itr /= 0) iky = strIdx(ky(itr)%key(:), keyn); IF(iky==0) RETURN !--- Wanted key index val = ky(itr)%val(iky) END FUNCTION getKeyByName_prv END FUNCTION getKeyByName_s1 !============================================================================================================================== LOGICAL FUNCTION getKeyByName_sm(keyn, val, tnam, ky) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn CHARACTER(LEN=256), ALLOCATABLE, INTENT(OUT) :: val(:) CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tnam(:) TYPE(kys), TARGET, OPTIONAL, INTENT(IN) :: ky(:) CHARACTER(LEN=256), POINTER :: n(:) INTEGER :: iq n => tracers(:)%keys%name; IF(PRESENT(tnam)) n => tnam(:) ALLOCATE(val(SIZE(n))) IF( PRESENT(ky)) lerr = ANY([(getKeyByName_s1(keyn, val(iq), n(iq), ky), iq=1, SIZE(n))]) IF(.NOT.PRESENT(ky)) lerr = ANY([(getKeyByName_s1(keyn, val(iq), n(iq)), iq=1, SIZE(n))]) END FUNCTION getKeyByName_sm !============================================================================================================================== LOGICAL FUNCTION getKeyByName_i1(keyn, val, tnam, ky) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn INTEGER, INTENT(OUT) :: val CHARACTER(LEN=*), INTENT(IN) :: tnam TYPE(kys), OPTIONAL, INTENT(IN) :: ky(:) CHARACTER(LEN=256) :: sval INTEGER :: ierr IF( PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam, ky) IF(.NOT.PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam) IF(test(fmsg(lerr, 'key "'//TRIM(keyn)//'" or tracer "'//TRIM(tnam)//'" is missing'), lerr)) RETURN READ(sval, *, IOSTAT=ierr) val IF(test(fmsg(ierr/=0,'key "'//TRIM(keyn)//'" of tracer "'//TRIM(tnam)//'" is not an integer'), lerr)) RETURN END FUNCTION getKeyByName_i1 !============================================================================================================================== LOGICAL FUNCTION getKeyByName_im(keyn, val, tnam, ky) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:) CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tnam(:) TYPE(kys), TARGET, OPTIONAL, INTENT(IN) :: ky(:) CHARACTER(LEN=256), POINTER :: n(:) INTEGER :: iq n => tracers(:)%name; IF(PRESENT(tnam)) n => tnam(:) ALLOCATE(val(SIZE(n))) IF( PRESENT(ky)) lerr = ANY([(getKeyByName_i1(keyn, val(iq), n(iq), ky), iq=1, SIZE(n))]) IF(.NOT.PRESENT(ky)) lerr = ANY([(getKeyByName_i1(keyn, val(iq), n(iq)), iq=1, SIZE(n))]) END FUNCTION getKeyByName_im !============================================================================================================================== LOGICAL FUNCTION getKeyByName_r1(keyn, val, tnam, ky) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn REAL, INTENT(OUT) :: val CHARACTER(LEN=*), INTENT(IN) :: tnam TYPE(kys), OPTIONAL, INTENT(IN) :: ky(:) CHARACTER(LEN=256) :: sval INTEGER :: ierr IF( PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam, ky) IF(.NOT.PRESENT(ky)) lerr = getKeyByName_s1(keyn, sval, tnam) IF(test(fmsg(lerr, 'key "'//TRIM(keyn)//'" or tracer "'//TRIM(tnam)//'" is missing'), lerr)) RETURN READ(sval, *, IOSTAT=ierr) val IF(test(fmsg(ierr/=0,'key "'//TRIM(keyn)//'" of tracer "'//TRIM(tnam)//'" is not a real'), lerr)) RETURN END FUNCTION getKeyByName_r1 !============================================================================================================================== LOGICAL FUNCTION getKeyByName_rm(keyn, val, tnam, ky) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn REAL, ALLOCATABLE, INTENT(OUT) :: val(:) CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tnam(:) TYPE(kys), TARGET, OPTIONAL, INTENT(IN) :: ky(:) CHARACTER(LEN=256), POINTER :: n(:) INTEGER :: iq n => tracers(:)%name; IF(PRESENT(tnam)) n => tnam(:) ALLOCATE(val(SIZE(n))) IF( PRESENT(ky)) lerr = ANY([(getKeyByName_r1(keyn, val(iq), n(iq), ky), iq=1, SIZE(n))]) IF(.NOT.PRESENT(ky)) lerr = ANY([(getKeyByName_r1(keyn, val(iq), n(iq)), iq=1, SIZE(n))]) END FUNCTION getKeyByName_rm !============================================================================================================================== !============================================================================================================================== !=== REMOVE, IF ANY, OR ADD THE PHASE SUFFIX OF THE TRACER NAMED "s" ========================================================== !============================================================================================================================== ELEMENTAL CHARACTER(LEN=256) FUNCTION delPhase(s) RESULT(out) CHARACTER(LEN=*), INTENT(IN) :: s INTEGER :: l, i, ix out = s IF(s == '') RETURN !--- Empty string: nothing to do !--- Index of found phase in "known_phases" ix = MAXLOC( [(i, i=1,nphases)], MASK=[( INDEX(s, phases_sep//known_phases(i:i))/=0, i=1, nphases)], DIM=1 ) IF(ix == 0) RETURN !--- No phase pattern found i = INDEX(s, phases_sep//known_phases(ix:ix)) !--- Index of pattern in "str" l = LEN_TRIM(s) IF(i == l-1) THEN !--- => return out = s(1:l-2) ELSE IF(s(i+2:i+2) == '_') THEN !--- _ => return _ out = s(1:i-1)//s(i+2:l) END IF END FUNCTION delPhase !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=256) FUNCTION addPhase_1(s,pha) RESULT(out) CHARACTER(LEN=*), INTENT(IN) :: s CHARACTER(LEN=1), INTENT(IN) :: pha INTEGER :: l, i out = s IF(s == '') RETURN !--- Empty string: nothing to do i = INDEX(s, '_') !--- /=0 for _ tracers names l = LEN_TRIM(s) IF(i == 0) out = TRIM(s)//phases_sep//pha !--- => return IF(i /= 0) out = s(1:i-1)//phases_sep//pha//'_'//s(i+1:l) !--- _ => return _ END FUNCTION addPhase_1 !------------------------------------------------------------------------------------------------------------------------------ FUNCTION addPhase_m(s,pha) RESULT(out) CHARACTER(LEN=*), INTENT(IN) :: s(:) CHARACTER(LEN=1), INTENT(IN) :: pha CHARACTER(LEN=256), ALLOCATABLE :: out(:) INTEGER :: k out = [( addPhase_1(s(k), pha), k=1, SIZE(s) )] END FUNCTION addPhase_m !------------------------------------------------------------------------------------------------------------------------------ !============================================================================================================================== !=== GET THE NAME(S) OF THE ANCESTOR(S) OF TRACER(S) "tname" AT GENERATION "igen" IN THE TRACERS DESCRIPTORS LIST "tr" ======= !============================================================================================================================== CHARACTER(LEN=256) FUNCTION ancestor_1(t, tname, igen) RESULT(out) TYPE(tra), INTENT(IN) :: t(:) CHARACTER(LEN=*), INTENT(IN) :: tname INTEGER, OPTIONAL, INTENT(IN) :: igen INTEGER :: ig, ix ig = 1; IF(PRESENT(igen)) ig = igen ix = idxAncestor_1(t, tname, ig) out = ''; IF(ix /= 0) out = t(ix)%name END FUNCTION ancestor_1 !------------------------------------------------------------------------------------------------------------------------------ FUNCTION ancestor_m(t, tname, igen) RESULT(out) CHARACTER(LEN=256), ALLOCATABLE :: out(:) TYPE(tra), INTENT(IN) :: t(:) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: tname(:) INTEGER, OPTIONAL, INTENT(IN) :: igen INTEGER, ALLOCATABLE :: ix(:) INTEGER :: ig ig = 1; IF(PRESENT(igen)) ig = igen IF( PRESENT(tname)) ix = idxAncestor_m(t, tname, ig) IF(.NOT.PRESENT(tname)) ix = idxAncestor_m(t, t(:)%name, ig) ALLOCATE(out(SIZE(ix))); out(:) = '' WHERE(ix /= 0) out = t(ix)%name END FUNCTION ancestor_m !============================================================================================================================== !============================================================================================================================== !=== GET THE INDEX(ES) OF THE ANCESTOR(S) OF TRACER(S) "tname" AT GENERATION "igen" IN THE TRACERS DESCRIPTORS LIST "tr" ===== !============================================================================================================================== INTEGER FUNCTION idxAncestor_1(t, tname, igen) RESULT(out) ! Return the name of the generation "igen" ancestor of "tname" TYPE(tra), INTENT(IN) :: t(:) CHARACTER(LEN=*), INTENT(IN) :: tname INTEGER, OPTIONAL, INTENT(IN) :: igen INTEGER :: ig ig = 1; IF(PRESENT(igen)) ig = igen out = strIdx(t(:)%name, tname) IF(out == 0) RETURN IF(t(out)%igen <= ig) RETURN DO WHILE(t(out)%igen > ig); out = strIdx(t(:)%name, t(out)%prnt); END DO END FUNCTION idxAncestor_1 !------------------------------------------------------------------------------------------------------------------------------ FUNCTION idxAncestor_m(t, tname, igen) RESULT(out) INTEGER, ALLOCATABLE :: out(:) TYPE(tra), INTENT(IN) :: t(:) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: tname(:) INTEGER, OPTIONAL, INTENT(IN) :: igen INTEGER :: ig, ix ig = 1; IF(PRESENT(igen)) ig = igen IF( PRESENT(tname)) out = [(idxAncestor_1(t, tname(ix), ig), ix=1, SIZE(tname))] IF(.NOT.PRESENT(tname)) out = [(idxAncestor_1(t, t(ix)%name, ig), ix=1, SIZE(t))] END FUNCTION idxAncestor_m !============================================================================================================================== END MODULE readTracFiles_mod