MODULE readTracFiles_mod USE strings_mod, ONLY: msg, testFile, strFind, strStack, strReduce, strHead, strCount, find, maxlen, fmsg, & removeComment, cat, checkList, strIdx, strParse, strReplace, strTail, reduceExpr, test, get_in, dispTable USE trac_types_mod, ONLY: trac_type, isot_type, keys_type IMPLICIT NONE PRIVATE PUBLIC :: initIsotopes, maxlen, trac_type, isot_type, keys_type PUBLIC :: readTracersFiles, indexUpdate, setGeneration !--- TOOLS ASSOCIATED TO TRACERS DESCRIPTORS PUBLIC :: readIsotopesFile !--- TOOLS ASSOCIATED TO ISOTOPES DESCRIPTORS PUBLIC :: getKey_init, getKey, setDirectKeys !--- GET/SET KEYS FROM/TO tracers & isotopes PUBLIC :: known_phases, old_phases, nphases, phases_names, & !--- VARIABLES RELATED TO THE PHASES phases_sep, delPhase, addPhase, & !--- + ROUTINES TO ADD/REMOVE PHASE TO/FROM A NAME old2newPhase, new2oldPhase PUBLIC :: tran0, idxAncestor, ancestor !--- GENERATION 0 TRACER + TOOLS FOR GENERATIONS !------------------------------------------------------------------------------------------------------------------------------ TYPE :: dataBase_type !=== TYPE FOR TRACERS SECTION CHARACTER(LEN=maxlen) :: name !--- Section name TYPE(trac_type), ALLOCATABLE :: trac(:) !--- Tracers descriptors END TYPE dataBase_type !------------------------------------------------------------------------------------------------------------------------------ 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_gen0Name; 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_s1, addPhase_sm, addPhase_i1, addPhase_im; END INTERFACE addPhase !------------------------------------------------------------------------------------------------------------------------------ !=== MAIN DATABASE: files sections descriptors TYPE(dataBase_type), SAVE, ALLOCATABLE, TARGET :: dBase(:) !--- SOME PARAMETERS THAT ARE NOT LIKELY TO CHANGE OFTEN CHARACTER(LEN=maxlen), SAVE :: tran0 = 'air' !--- Default transporting fluid CHARACTER(LEN=maxlen), PARAMETER :: old_phases = 'vlir' !--- Old phases for water (no separator) CHARACTER(LEN=maxlen), PARAMETER :: known_phases = 'glsr' !--- Known phases initials INTEGER, PARAMETER :: nphases=LEN_TRIM(known_phases) !--- Number of phases CHARACTER(LEN=maxlen), SAVE :: phases_names(nphases) & !--- Known phases names = ['gaseous', 'liquid ', 'solid ', 'cloud '] 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(trac_type), ALLOCATABLE, TARGET, SAVE :: tracers(:) TYPE(isot_type), ALLOCATABLE, TARGET, SAVE :: isotopes(:) CHARACTER(LEN=maxlen) :: modname 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 keys_type) 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 (longName, iadv, isAdvected for now). ! * 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: iqParent, iqDescen). ! * 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(trac_type), ALLOCATABLE, INTENT(OUT) :: tracs(:) CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:), sections(:), trac_files(:) CHARACTER(LEN=maxlen) :: str, fname, mesg, oldH2O, newH2O INTEGER :: is, nsec, ierr, it, ntrac, ns, ip, ix 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 !--- CHECK WHETHER type_trac AND FILE TYPE ARE COMPATIBLE IF(test(fmsg('No multiple sections for the old format "traceur.def"', ll = SIZE(sections)>1 .AND. fType==1), lerr)) RETURN !--- TELLS WHAT WAS IS ABOUT TO BE USED IF (fmsg('No adequate tracers description file(s) found ; default values will be used', modname, fType==0)) RETURN CALL msg('Trying to read old-style tracers description file "traceur.def"', modname, fType==1) CALL msg('Trying to read the new style multi-sections tracers description file "tracer.def"', modname, fType==2) CALL msg('Trying to read the new style single section tracers description files "tracer_*.def"', modname, fType==3) !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ SELECT CASE(fType) !--- Set %name, %genOName, %parent, %type, %phase, %component, %iGeneration, %keys !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CASE(1) !=== 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('Invalid format for "'//TRIM(fname)//'"', modname, ierr /= 0), 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('Invalid format for "' //TRIM(fname)//'"', modname, ierr>0), lerr)) RETURN IF(test(fmsg('Not enough lines in "'//TRIM(fname)//'"', modname, ierr<0), lerr)) RETURN ll = strParse(str, ' ', s, n=ns) CALL msg('This file is for air tracers only', modname, ns == 3 .AND. it == 1) CALL msg('This files specifies the transporting fluid', modname, ns == 4 .AND. it == 1) tracs(it)%name = TRIM(s(3)) !--- Set %name: name of the tracer tracs(it)%parent = tran0 !--- Set %parent: transporting fluid IF(ns == 4) tracs(it)%parent = s(4) !--- default: 'air' or defined in the file tracs(it)%phase = known_phases(1:1) !--- Set %phase: tracer phase (default: "g"azeous) tracs(it)%component = TRIM(type_trac) !--- Set %component: model component name tracs(it)%keys%key = ['hadv', 'vadv'] !--- Set %keys%key tracs(it)%keys%val = s(1:2) !--- Set %keys%val END DO CLOSE(90) DO ip = 1, nphases !--- Deal with old water names oldH2O = addPhase('H2O', ip, '') newH2O = addPhase('H2O', ip) ix = strIdx(tracs(:)%name, oldH2O) IF(ix == 0) CYCLE tracs(ix)%name = newH2O !--- Set %name: name of the tracer WHERE(tracs(:)%parent == oldH2O) tracs(:)%parent = newH2O !--- Set %parent: transporting fluid tracs(ix)%phase = known_phases(ip:ip) !--- Set %phase: tracer phase END DO CALL setGeneration(tracs) !--- Set %iGeneration and %gen0Name WHERE(tracs%iGeneration == 3) tracs%type = 'tag' !--- Set %type: 'tracer' or 'tag' IF(test(checkTracers(tracs, fname, fname), lerr)) RETURN !--- Detect orphans and check phases IF(test(checkUnique (tracs, fname, fname), lerr)) RETURN !--- Detect repeated tracers CALL sortTracers (tracs) !--- Sort the tracers tracs(:)%keys%name = tracs(:)%name !--- Copy tracers names in keys components !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CASE(2); IF(test(feedDBase(["tracer.def"],[type_trac]), lerr)) RETURN !=== SINGLE FILE, COMA-SEPARATED SECTIONS LIST !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CASE(3); IF(test(feedDBase( trac_files , sections ), lerr)) RETURN !=== MULTIPLE FILES, ONE SECTION EACH FILE !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ END SELECT !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(ANY([2,3] == fType) .AND. nsec > 1) THEN IF(tracs_merge) THEN CALL msg('The multiple required sections will be MERGED.', modname) IF(test(mergeTracers(dBase, tracs), lerr)) RETURN ELSE CALL msg('The multiple required sections will be CUMULATED.', modname) IF(test(cumulTracers(dBase, tracs), lerr)) RETURN END IF WHERE(tracs%gen0Name(1:3) /= 'H2O') tracs%isInPhysics=.TRUE. !--- Set %isInPhysics: passed to physics CALL setDirectKeys(tracs) !--- Set %iqParent, %iqDescen, %nqDescen, %nqChilds END IF 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=maxlen) :: fnm, snm, modname INTEGER :: idb, i LOGICAL :: ll !------------------------------------------------------------------------------------------------------------------------------ modname = 'feedDBase' !=== READ THE REQUIRED SECTIONS ll = strCount(snames, ',', ndb) !--- Number of sections for each file ALLOCATE(ixf(SUM(ndb))) DO i=1, SIZE(fnames) !--- Set %name, %keys 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 !--- FILE AND SECTION NAMES IF(test(expandSection(dBase(idb)%trac, snm, fnm), lerr)) RETURN !--- EXPAND NAMES ; set %parent, %type, %component CALL setGeneration (dBase(idb)%trac) !--- set %iGeneration, %genOName IF(test(checkTracers (dBase(idb)%trac, snm, fnm), lerr)) RETURN !--- CHECK ORPHANS AND PHASES IF(test(checkUnique (dBase(idb)%trac, snm, fnm), lerr)) RETURN !--- CHECK TRACERS UNIQUENESS CALL expandPhases (dBase(idb)%trac) !--- EXPAND PHASES ; set %phase 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, modname), & 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(dataBase_type), ALLOCATABLE :: tdb(:) CHARACTER(LEN=maxlen), 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=maxlen), ALLOCATABLE :: s(:), v(:) TYPE(trac_type), ALLOCATABLE :: tt(:) TYPE(trac_type) :: tmp CHARACTER(LEN=1024) :: str CHARACTER(LEN=maxlen) :: 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%keys = keys_type(s(1), s(2:n), v(2:n)) !--- Set %name and %keys dBase(ndb)%trac = [tt(:), tmp] DEALLOCATE(tt) ! dBase(ndb)%trac = [dBase(ndb)%trac(:), tra(name=s(1), keys=keys_type(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(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:) CHARACTER(LEN=*), INTENT(IN) :: defName INTEGER :: jd, it, k TYPE(keys_type), POINTER :: ky TYPE(trac_type), 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(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:) CHARACTER(LEN=*), INTENT(IN) :: defName LOGICAL, INTENT(IN) :: lSubLocal INTEGER :: i0, it, ik TYPE(keys_type), POINTER :: k0, ky TYPE(trac_type), 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(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector CHARACTER(LEN=*), INTENT(IN) :: sname CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname TYPE(trac_type), ALLOCATABLE :: ttr(:) CHARACTER(LEN=maxlen), ALLOCATABLE :: ta(:), pa(:) CHARACTER(LEN=maxlen) :: msg1, modname INTEGER :: it, nt, iq, nq, itr, ntr, ipr, npr, i LOGICAL :: ll modname = 'expandSection' 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)%parent = fgetKey(it, 'parent', tr(:)%keys, tran0 ) tr(it)%type = fgetKey(it, 'type' , tr(:)%keys, 'tracer') tr(it)%component = sname !--- Determine the number of tracers and parents ; coherence checking ll = strCount(tr(it)%name, ',', ntr) ll = strCount(tr(it)%parent, ',', 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', modname); 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)%parent, ',', 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 = TRIM(ta(itr)); ttr(i)%parent = pa(ipr) ttr(i)%keys = keys_type(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(:)": ! * %iGeneration: the generation number ! * %gen0Name: the generation 0 ancestor name !------------------------------------------------------------------------------------------------------------------------------ TYPE(trac_type), INTENT(INOUT) :: tr(:) !--- Tracer derived type vector INTEGER :: iq, nq, ig LOGICAL, ALLOCATABLE :: lg(:) CHARACTER(LEN=maxlen), ALLOCATABLE :: prn(:) !------------------------------------------------------------------------------------------------------------------------------ tr(:)%iGeneration = -1 !--- error if -1 nq = SIZE(tr, DIM=1) !--- Number of tracers lines lg = tr(:)%parent == tran0 !--- First generation tracers flag WHERE(lg) tr(:)%iGeneration = 0 !--- First generation tracers !=== Determine generation for each tracer ig=-1; prn = [tran0] DO !--- Update current generation flag IF(ig/=-1) prn = PACK( tr(:)%name, MASK=tr(:)%iGeneration == ig) lg(:) = [(ANY(prn(:) == tr(iq)%parent), iq=1, nq)] !--- Current generation tracers flag IF( ALL( .NOT. lg ) ) EXIT !--- Empty current generation ig = ig+1; WHERE(lg) tr(:)%iGeneration = ig END DO tr(:)%gen0Name = 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(trac_type), INTENT(IN) :: tr(:) !--- Tracer derived type vector CHARACTER(LEN=*), INTENT(IN) :: sname !--- Section name CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- File name CHARACTER(LEN=maxlen) :: mesg CHARACTER(LEN=maxlen) :: 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%iGeneration==-1, mesg, 'tracers', 'orphan'), lerr)) RETURN !=== CHECK PHASES DO iq=1,nq; IF(tr(iq)%iGeneration/=0) CYCLE !--- Generation O 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%iGeneration==0 .AND. bp/='', mesg, 'tracers phases', 'unknown') END FUNCTION checkTracers !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION checkUnique(tr, sname, fname) RESULT(lerr) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: Make sure that tracers are not repeated. !------------------------------------------------------------------------------------------------------------------------------ TYPE(trac_type), INTENT(IN) :: tr(:) !--- Tracer derived type vector 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=maxlen) :: 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(tr(iq)%type == 'tag') CYCLE !--- Tags can be repeated tnam = TRIM(tr(iq)%name) ll = tr(:)%name==TRIM(tnam) !--- Mask for current tracer name IF(COUNT(ll)==1 ) CYCLE !--- Tracer is not repeated IF(tr(iq)%iGeneration>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(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector !------------------------------------------------------------------------------------------------------------------------------ TYPE(trac_type), ALLOCATABLE :: ttr(:) INTEGER, ALLOCATABLE :: i0(:) CHARACTER(LEN=maxlen) :: 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)%iGeneration /= 1) CYCLE nc = COUNT(tr(:)%gen0Name==tr(iq)%name .AND. tr%iGeneration/=1) !--- Number of childs of tr(iq) tr(iq)%phase = fgetKey(iq, 'phases', tr(:)%keys) !--- Phases list of tr(iq) np = LEN_TRIM(tr(iq)%phase) !--- 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, TRIM(tr(iq)%gen0Name), n) !--- Indexes of first generation ancestor copies np = SUM( [( LEN_TRIM(tr(i0(i))%phase),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)%iGeneration>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)%iGeneration==1) jq=iq !--- Generation 1: current tracer phases only pha = tr(jq)%phase !--- 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)%parent) !--- Parent name (tagging case) IF(lEx) nam = addPhase(nam, ip) !--- Phase extension needed IF(lTg) nam = TRIM(nam)//'_'//TRIM(trn) !--- _ for tags ttr(it) = tr(iq) !--- Same = pairs ttr(it)%name = TRIM(nam) !--- Name with possibly phase suffix ttr(it)%keys%name = TRIM(nam) !--- Name inside the keys decriptor ttr(it)%phase = pha(ip:ip) !--- Single phase entry IF(lEx.AND.tr(iq)%iGeneration>1) THEN ttr(it)%parent = addPhase(ttr(it)%parent, ip) !--- Modify parent name ttr(it)%gen0Name = addPhase(ttr(it)%gen0Name, ip) !--- Modify generation 0 ancestor name END IF it=it+1 END DO IF(tr(iq)%iGeneration==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: ! * Put water at first places, in the "known_phases" order. ! * lGrowGen == T: in ascending generations numbers. ! * lGrowGen == F: tracer + its childs sorted by growing generation, one after the other. ! TO BE ADDED IF NECESSARY: HIGHER MOMENTS AT THE END !------------------------------------------------------------------------------------------------------------------------------ TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector INTEGER :: ig, ng, iq, jq, ip, nq, n, ix(SIZE(tr)), k INTEGER, ALLOCATABLE :: iy(:), iz(:) !------------------------------------------------------------------------------------------------------------------------------ nq = SIZE(tr) iy = [(k, k=1, nq)] DO ip = nphases, 1, -1 iq = strIdx(tr(:)%name, addPhase('H2O', ip)) IF(iq/=0) iy = [iq, iy(1:iq-1), iy(iq+1:nq)] END DO tr = tr(iy) !--- Water displaces at first positions iq = 1 IF(lSortByGen) THEN ng = MAXVAL(tr(:)%iGeneration, MASK=.TRUE., DIM=1) !--- Number of generations DO ig = 0, ng !--- Loop on generations iy = PACK([(k, k=1, nq)], MASK=tr(:)%iGeneration==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, nq !--- Loop on first generation tracers IF(tr(jq)%iGeneration /= 1) CYCLE !--- Skip generations >= 1 ix(iq) = jq !--- First generation ancestor index first iq = iq + 1 iy = strFind(tr(:)%gen0Name, TRIM(tr(jq)%name)) !--- Indexes of "tr(jq)" childs in "tr(:)" ng = MAXVAL(tr(iy)%iGeneration, 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)%iGeneration, 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(dataBase_type), TARGET, INTENT(IN) :: sections(:) TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: tr(:) TYPE(trac_type), POINTER :: t1(:), t2(:) INTEGER, ALLOCATABLE :: ixct(:), ixck(:) INTEGER :: is, k1, k2, nk2, i1, i2, nt2 CHARACTER(LEN=maxlen) :: s1, v1, v2, tnam, knam, modname modname = 'mergeTracers' 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)//'":', modname) CALL msg(t1(PACK(ixct, MASK = ixct/=0))%name, modname, nmax=128) !--- Display duplicates (the 128 first at most) !-------------------------------------------------------------------------------------------------------------------------- DO i2=1,nt2; tnam = TRIM(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('Parent name'//TRIM(s1), modname, t1(i1)%parent /= t2(i2)%parent), lerr)) RETURN IF(test(fmsg('Type' //TRIM(s1), modname, t1(i1)%type /= t2(i2)%type), lerr)) RETURN IF(test(fmsg('Generation' //TRIM(s1), modname, t1(i1)%iGeneration /= t2(i2)%iGeneration), 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)%component = TRIM(tr(i1)%component)//','//TRIM(tr(i2)%component) !--- 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), modname) 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), modname) END DO !------------------------------------------------------------------------------------------------------------------------ END DO !-------------------------------------------------------------------------------------------------------------------------- END DO CALL sortTracers(tr) END FUNCTION mergeTracers !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION cumulTracers(sections, tr) RESULT(lerr) TYPE(dataBase_type), TARGET, INTENT(IN) :: sections(:) TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: tr(:) TYPE(trac_type), POINTER :: t1(:), t2(:) INTEGER, ALLOCATABLE :: nt(:) CHARACTER(LEN=maxlen) :: 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 = TRIM(t1(iq)%name) !--- Original name IF(COUNT(t1%name == tnam) == 1) CYCLE !--- Current tracer is not duplicated: finished tnam_new = TRIM(tnam)//'_'//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 = TRIM(tnam_new) !--- Modify tracer name WHERE(tr(1+nq:ns+nq)%parent==tnam) tr(1+nq:ns+nq)%parent=tnam_new !--- Modify parent name !-------------------------------------------------------------------------------------------------------------------------- END DO !---------------------------------------------------------------------------------------------------------------------------- END DO !---------------------------------------------------------------------------------------------------------------------------- CALL sortTracers(tr) END FUNCTION cumulTracers !============================================================================================================================== !============================================================================================================================== SUBROUTINE setDirectKeys(tr) TYPE(trac_type), INTENT(INOUT) :: tr(:) !--- Update %iqParent, %iqDescen, %nqDescen, %nqChilds CALL indexUpdate(tr) !--- Extract some direct-access keys ! DO iq = 1, SIZE(tr) ! tr(iq)%keys% = getKey_prv(it, "", tr%keys, ) ! END DO END SUBROUTINE setDirectKeys !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION dispTraSection(message, sname, modname) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: message, sname, modname INTEGER :: idb, iq, nq INTEGER, ALLOCATABLE :: hadv(:), vadv(:) TYPE(trac_type), 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)//':', modname) IF(test(dispTable('iiissis', ['iq ','hadv ','vadv ','short name','parent ','igen ','phase '], & cat(tm(:)%name, tm(:)%parent, tm(:)%phase), cat([(iq, iq=1, nq)], hadv, vadv, tm(:)%iGeneration)), 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(trac_type), POINTER :: out CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(trac_type), 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(trac_type), ALLOCATABLE :: out(:) TYPE(trac_type), 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(trac_type), ALLOCATABLE :: out(:) TYPE(trac_type), 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_gen0Name(trac,nam) RESULT(out) TYPE(trac_type), ALLOCATABLE :: out(:) TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:) CHARACTER(LEN=*), INTENT(IN) :: nam out = trac(strFind(delPhase(trac(:)%gen0Name), nam)) CALL indexUpdate(out) END FUNCTION trSubset_gen0Name !------------------------------------------------------------------------------------------------------------------------------ !============================================================================================================================== !=== UPDATE THE INDEXES iqParent, iqDescend AND iGeneration IN THE TRACERS DESCRIPTOR LIST "tr" (USEFULL FOR SUBSETS) ========= !============================================================================================================================== SUBROUTINE indexUpdate(tr) TYPE(trac_type), INTENT(INOUT) :: tr(:) INTEGER :: iq, ig, ng, ngen INTEGER, ALLOCATABLE :: ix(:) tr(:)%iqParent = strIdx( tr(:)%name, tr(:)%parent ) !--- Parent index ngen = MAXVAL(tr(:)%iGeneration, MASK=.TRUE.) DO iq = 1, SIZE(tr) ng = tr(iq)%iGeneration !--- 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)%iqDescen = [( PACK(ix, MASK = tr(ix)%iGeneration == ig), ig = ng+1, ngen)] tr(iq)%nqDescen = SUM( [( COUNT(tr(ix)%iGeneration == ig), ig = ng+1, ngen)] ) tr(iq)%nqChilds = COUNT(tr(ix)%iGeneration == 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(:)%parent": ==== !=== * Each section dBase(i)%name contains the isotopes "dBase(i)%trac(:)" descending on "dBase(i)%name"="iso(i)%parent" ==== !=== * 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): ==== !=== parent, nzone, zone(:), niso, keys(:)%name, ntiso, trac(:), nphas, 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(isot_type), 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=maxlen), POINTER :: k(:), v(:), k0(:), v0(:) CHARACTER(LEN=maxlen), ALLOCATABLE :: vals(:) CHARACTER(LEN=maxlen) :: val, modname TYPE(keys_type), POINTER :: ky(:) TYPE(trac_type), POINTER :: tt(:), t TYPE(dataBase_type), ALLOCATABLE :: tdb(:) LOGICAL, ALLOCATABLE :: liso(:) modname = 'readIsotopesFile' !--- THE INPUT FILE MUST BE PRESENT IF(test(fmsg('Missing isotopes parameters file "'//TRIM(fnam)//'"', modname, testFile(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(:)%parent,',')),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', modname) 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(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: trac(:) TYPE(isot_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: isot(:) CHARACTER(LEN=maxlen), ALLOCATABLE :: p(:), str(:) !--- Temporary storage CHARACTER(LEN=maxlen) :: iname CHARACTER(LEN=1) :: ph !--- Phase INTEGER :: nbIso, ic, ip, iq, it, iz LOGICAL, ALLOCATABLE :: ll(:) !--- Mask TYPE(trac_type), POINTER :: t(:), t1 TYPE(isot_type), POINTER :: s t => trac p = PACK(delPhase(t%parent), MASK = t%type=='tracer' .AND. t%iGeneration==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(:)%parent = p DO ic = 1, SIZE(p) !--- Loop on isotopes classes s => isot(ic) iname = s%parent !--- 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(:)%parent) == iname .AND. t(:)%phase == '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(:)%gen0Name) == iname .AND. t(:)%iGeneration == 3 s%zone = PACK(strTail(t(:)%name,'_',lFirst=.TRUE.), MASK = ll) !--- Tagging zones names for isotopes category "iname" CALL strReduce(s%zone) s%nzone = 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%ntiso = s%niso + SIZE(str) !--- Number of isotopes + their geographic tracers [ntraciso] ALLOCATE(s%trac(s%ntiso)) FORALL(it = 1:s%niso) s%trac(it) = s%keys(it)%name FORALL(it = s%niso+1:s%ntiso) s%trac(it) = str(it-s%niso) !=== Phases for tracer "iname" s%phase = '' 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 s%nphas = LEN_TRIM(s%phase) !--- 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%gen0Name) /= iname) CYCLE !--- Only deal with tracers descending on "iname" t1%iso_iGroup = ic !--- Isotopes family idx in list "isotopes(:)%parent" t1%iso_iName = strIdx(s%trac, delPhase(strHead(t1%name,'_'))) !--- Current isotope idx in effective isotopes list t1%iso_iZone = strIdx(s%zone, strTail(t1%name,'_') ) !--- Current isotope zone idx in effective zones list t1%iso_iPhase = INDEX(s%phase,TRIM(t1%phase)) !--- Current isotope phase idx in effective phases list IF(t1%iGeneration /= 3) t1%iso_iZone = 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%phase(ip:ip))), it=1, s%ntiso), ip=1, s%nphas)], & [s%ntiso, s%nphas] ) !=== Table used to get ix (index in tagging tracers isotopes list, size ntiso) from the zone and isotope indexes s%iZonIso = RESHAPE( [( (strIdx(s%trac(:), TRIM(s%trac(it))//'_'//TRIM(s%zone(iz))), iz=1, s%nzone), it=1, s%niso )], & [s%nzone, s%niso] ) END DO !=== 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, modname) RESULT(lerr) TYPE(isot_type), INTENT(IN) :: ides(:) !--- Isotopes descriptor vector CHARACTER(LEN=*), INTENT(IN) :: message !--- Message to display CHARACTER(LEN=*), INTENT(IN) :: modname !--- Calling subroutine name INTEGER :: ik, nk, ip, it, nt CHARACTER(LEN=maxlen) :: prf CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:), val(:,:) CALL msg(TRIM(message)//':', modname) 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('Problem with the table content', modname, dispTable(prf, ttl, val, cat([(it,it=1,nt)]), rFmt='(EN8.4)')), & 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(keys_type), INTENT(INOUT) :: ky LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite CHARACTER(LEN=maxlen), 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(keys_type), 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(trac_type), ALLOCATABLE, INTENT(INOUT) :: t(:) CHARACTER(LEN=*), INTENT(IN) :: tr0 CHARACTER(LEN=maxlen) :: 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(trac_type), INTENT(INOUT) :: ky(:) CHARACTER(LEN=maxlen), 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(trac_type), 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(trac_type), OPTIONAL, INTENT(IN) :: tracers_(:) TYPE(isot_type), OPTIONAL, INTENT(IN) :: isotopes_(:) IF(PRESENT( tracers_)) tracers = tracers_ IF(PRESENT(isotopes_)) isotopes = isotopes_ END SUBROUTINE getKey_init !============================================================================================================================== CHARACTER(LEN=maxlen) 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(keys_type), 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=maxlen), INTENT(OUT) :: val CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(keys_type), 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=maxlen) :: val CHARACTER(LEN=*), INTENT(IN) :: keyn CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(keys_type), 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=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) CHARACTER(LEN=*), TARGET, OPTIONAL, INTENT(IN) :: tnam(:) TYPE(keys_type), TARGET, OPTIONAL, INTENT(IN) :: ky(:) TYPE(keys_type), POINTER :: k(:) CHARACTER(LEN=maxlen), POINTER :: n(:) INTEGER :: iq k => tracers(:)%keys; IF(PRESENT(ky )) k => ky n => k(:)%name; IF(PRESENT(tnam)) n => tnam ALLOCATE(val(SIZE(n))) lerr = ANY([(getKeyByName_s1(keyn, val(iq), n(iq), k), 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(keys_type), OPTIONAL, INTENT(IN) :: ky(:) CHARACTER(LEN=maxlen) :: 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('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tnam)//'" is missing', modname, lerr), lerr)) RETURN READ(sval, *, IOSTAT=ierr) val IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tnam)//'" is not an integer', modname, lerr), 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(keys_type), TARGET, OPTIONAL, INTENT(IN) :: ky(:) TYPE(keys_type), POINTER :: k(:) CHARACTER(LEN=maxlen), POINTER :: n(:) INTEGER :: iq k => tracers(:)%keys; IF(PRESENT(ky )) k => ky n => k(:)%name; IF(PRESENT(tnam)) n => tnam ALLOCATE(val(SIZE(n))) lerr = ANY([(getKeyByName_i1(keyn, val(iq), n(iq), k), 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(keys_type), OPTIONAL, INTENT(IN) :: ky(:) CHARACTER(LEN=maxlen) :: 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('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tnam)//'" is missing', modname, lerr), lerr)) RETURN READ(sval, *, IOSTAT=ierr) val IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tnam)//'" is not a real', modname, lerr), 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(keys_type), TARGET, OPTIONAL, INTENT(IN) :: ky(:) TYPE(keys_type), POINTER :: k(:) CHARACTER(LEN=maxlen), POINTER :: n(:) INTEGER :: iq k => tracers(:)%keys; IF(PRESENT(ky )) k => ky n => k(:)%name; IF(PRESENT(tnam)) n => tnam ALLOCATE(val(SIZE(n))) lerr = ANY([(getKeyByName_r1(keyn, val(iq), n(iq), k), iq=1, SIZE(n))]) END FUNCTION getKeyByName_rm !============================================================================================================================== !============================================================================================================================== !=== REMOVE, IF ANY, OR ADD THE PHASE SUFFIX OF THE TRACER NAMED "s" ========================================================== !============================================================================================================================== ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION delPhase(s) RESULT(out) CHARACTER(LEN=*), INTENT(IN) :: s INTEGER :: l, i, ix CHARACTER(LEN=maxlen) :: sh, st out = s IF(s == '') RETURN !--- Empty string: nothing to do !--- Special case: old phases for water, no phases separator i = INDEX(s,'_'); sh = s; IF(i/=0) sh=s(1:i-1); st='H2O'; IF(i/=0) st='H2O_'//s(i+1:LEN_TRIM(s)) IF(ANY([('H2O'//old_phases(ix:ix), ix=1, nphases)] == sh)) THEN; out=st; RETURN; END IF !--- 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=maxlen) FUNCTION addPhase_s1(s,pha,ph_sep) RESULT(out) CHARACTER(LEN=*), INTENT(IN) :: s CHARACTER(LEN=1), INTENT(IN) :: pha CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: ph_sep CHARACTER(LEN=1) :: psep INTEGER :: l, i out = s IF(s == '') RETURN !--- Empty string: nothing to do psep = phases_sep; IF(PRESENT(ph_sep)) psep = ph_sep i = INDEX(s, '_') !--- /=0 for _ tracers names l = LEN_TRIM(s) IF(i == 0) out = TRIM(s)//TRIM(psep)//pha !--- => return IF(i /= 0) out = s(1:i-1)//TRIM(psep)//pha//'_'//s(i+1:l) !--- _ => return _ END FUNCTION addPhase_s1 !------------------------------------------------------------------------------------------------------------------------------ FUNCTION addPhase_sm(s,pha,ph_sep) RESULT(out) CHARACTER(LEN=*), INTENT(IN) :: s(:) CHARACTER(LEN=1), INTENT(IN) :: pha CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: ph_sep CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) CHARACTER(LEN=1) :: psep INTEGER :: k psep = phases_sep; IF(PRESENT(ph_sep)) psep = ph_sep out = [( addPhase_s1(s(k), pha, psep), k=1, SIZE(s) )] END FUNCTION addPhase_sm !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) FUNCTION addPhase_i1(s,ipha,ph_sep) RESULT(out) CHARACTER(LEN=*), INTENT(IN) :: s INTEGER, INTENT(IN) :: ipha CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: ph_sep CHARACTER(LEN=1) :: psep out = s IF(s == '') RETURN !--- Empty string: nothing to do psep = phases_sep; IF(PRESENT(ph_sep)) psep = ph_sep IF(psep == '') out = addPhase_s1(s, old_phases(ipha:ipha), psep) IF(psep /= '') out = addPhase_s1(s, known_phases(ipha:ipha), psep) END FUNCTION addPhase_i1 !------------------------------------------------------------------------------------------------------------------------------ FUNCTION addPhase_im(s,ipha,ph_sep) RESULT(out) CHARACTER(LEN=*), INTENT(IN) :: s(:) INTEGER, INTENT(IN) :: ipha CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: ph_sep CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) CHARACTER(LEN=1) :: psep INTEGER :: k psep = phases_sep; IF(PRESENT(ph_sep)) psep = ph_sep out = [( addPhase_i1(s(k), ipha, psep), k=1, SIZE(s) )] END FUNCTION addPhase_im !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=1) FUNCTION old2newPhase(op) RESULT(np) CHARACTER(LEN=1), INTENT(IN) :: op np = known_phases(INDEX(old_phases,op):INDEX(old_phases,op)) END FUNCTION old2newPhase CHARACTER(LEN=1) FUNCTION new2oldPhase(np) RESULT(op) CHARACTER(LEN=1), INTENT(IN) :: np op = old_phases(INDEX(known_phases,np):INDEX(known_phases,np)) END FUNCTION new2oldPhase !============================================================================================================================== !=== GET THE NAME(S) OF THE ANCESTOR(S) OF TRACER(S) "tname" AT GENERATION "igen" IN THE TRACERS DESCRIPTORS LIST "tr" ======= !============================================================================================================================== CHARACTER(LEN=maxlen) FUNCTION ancestor_1(t, tname, igen) RESULT(out) TYPE(trac_type), INTENT(IN) :: t(:) CHARACTER(LEN=*), INTENT(IN) :: tname INTEGER, OPTIONAL, INTENT(IN) :: igen INTEGER :: ig, ix ig = 0; 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=maxlen), ALLOCATABLE :: out(:) TYPE(trac_type), INTENT(IN) :: t(:) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: tname(:) INTEGER, OPTIONAL, INTENT(IN) :: igen INTEGER, ALLOCATABLE :: ix(:) INTEGER :: ig ig = 0; 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" (>=0) ancestor of "tname" TYPE(trac_type), INTENT(IN) :: t(:) CHARACTER(LEN=*), INTENT(IN) :: tname INTEGER, OPTIONAL, INTENT(IN) :: igen INTEGER :: ig ig = 0; IF(PRESENT(igen)) ig = igen out = strIdx(t(:)%name, tname) IF(out == 0) RETURN !--- Tracer not found IF(t(out)%iGeneration <= ig) RETURN !--- Tracer has a lower generation number than asked generation 'igen" DO WHILE(t(out)%iGeneration > ig); out = strIdx(t(:)%name, t(out)%parent); END DO END FUNCTION idxAncestor_1 !------------------------------------------------------------------------------------------------------------------------------ FUNCTION idxAncestor_m(t, tname, igen) RESULT(out) INTEGER, ALLOCATABLE :: out(:) TYPE(trac_type), INTENT(IN) :: t(:) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: tname(:) INTEGER, OPTIONAL, INTENT(IN) :: igen INTEGER :: ig, ix ig = 0; 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