MODULE readTracFiles_mod USE strings_mod, ONLY: msg, find, get_in, dispTable, strHead, strReduce, strFind, strStack, strIdx, & test, removeComment, cat, fmsg, maxlen, checkList, strParse, strReplace, strTail, strCount, reduceExpr, & int2str, str2int, real2str, str2real, bool2str, str2bool IMPLICIT NONE PRIVATE PUBLIC :: maxlen !--- PARAMETER FOR CASUAL STRING LENGTH PUBLIC :: trac_type, tracers, setGeneration, indexUpdate !--- TRACERS DESCRIPTION DATABASE + ASSOCIATED TOOLS PUBLIC :: testTracersFiles, readTracersFiles !--- TRACERS FILES READING ROUTINES PUBLIC :: getKeysDBase, setKeysDBase !--- TOOLS TO GET/SET THE DATABASE (tracers & isotopes) PUBLIC :: addTracer, delTracer !--- ADD/REMOVE A TRACER FROM PUBLIC :: addKey, delKey, getKey, keys_type !--- TOOLS TO SET/DEL/GET KEYS FROM/TO tracers & isotopes PUBLIC :: addPhase, delPhase, getPhase, getiPhase, & !--- FUNCTIONS RELATED TO THE PHASES nphases, old_phases, phases_sep, known_phases, phases_names !--- + ASSOCIATED VARIABLES PUBLIC :: fGetKey, fGetKeys, setDirectKeys !--- TOOLS TO GET/SET KEYS FROM/TO tracers & isotopes TO BE REMOVED PUBLIC :: oldH2OIso, newH2OIso, old2newH2O, new2oldH2O !--- H2O ISOTOPES BACKWARD COMPATIBILITY (OLD traceur.def) PUBLIC :: oldHNO3, newHNO3 !--- HNO3 REPRO BACKWARD COMPATIBILITY (OLD start.nc) PUBLIC :: tran0, idxAncestor, ancestor !--- GENERATION 0 TRACER + TOOLS FOR GENERATIONS !=== FOR ISOTOPES: GENERAL PUBLIC :: isot_type, readIsotopesFile, isoSelect, ixIso, nbIso!--- ISOTOPES READING ROUTINE + SELECTION + CLASS IDX & NUMBER !=== FOR ISOTOPES: H2O FAMILY ONLY PUBLIC :: iH2O !=== FOR ISOTOPES: DEPENDING ON THE SELECTED ISOTOPES CLASS PUBLIC :: isotope, isoKeys !--- SELECTED ISOTOPES DATABASE + ASSOCIATED KEYS PUBLIC :: isoName, isoZone, isoPhas !--- ISOTOPES AND TAGGING ZONES NAMES AND PHASES PUBLIC :: niso, nzone, nphas, ntiso !--- " " NUMBERS + ISOTOPES AND TAGGING TRACERS NUMBERS PUBLIC :: itZonIso !--- Idx IN isoName(1:niso) = f(tagging idx, isotope idx) PUBLIC :: iqIsoPha !--- Idx IN qx(1:nqtot) = f(isotope idx, phase idx) PUBLIC :: iqWIsoPha !--- Idx IN qx(1:nqtot) = f(isotope idx, phase idx) but with normal water first PUBLIC :: isoCheck !--- FLAG TO RUN ISOTOPES CHECKING ROUTINES PUBLIC :: maxTableWidth !------------------------------------------------------------------------------------------------------------------------------ TYPE :: keys_type !=== TYPE FOR A SET OF KEYS ASSOCIATED TO AN ELEMENT CHARACTER(LEN=maxlen) :: name !--- Tracer name CHARACTER(LEN=maxlen), ALLOCATABLE :: key(:) !--- Keys string list CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:) !--- Corresponding values string list END TYPE keys_type !------------------------------------------------------------------------------------------------------------------------------ TYPE :: trac_type !=== TYPE FOR A SINGLE TRACER NAMED "name" CHARACTER(LEN=maxlen) :: name = '' !--- Name of the tracer TYPE(keys_type) :: keys !--- = pairs vector CHARACTER(LEN=maxlen) :: gen0Name = '' !--- First generation ancestor name CHARACTER(LEN=maxlen) :: parent = '' !--- Parent name CHARACTER(LEN=maxlen) :: longName = '' !--- Long name (with advection scheme suffix) CHARACTER(LEN=maxlen) :: type = 'tracer' !--- Type (so far: 'tracer' / 'tag') CHARACTER(LEN=maxlen) :: phase = 'g' !--- Phase ('g'as / 'l'iquid / 's'olid) CHARACTER(LEN=maxlen) :: component = '' !--- Coma-separated list of components (Ex: lmdz,inca) INTEGER :: iGeneration = -1 !--- Generation number (>=0) INTEGER :: iqParent = 0 !--- Parent index INTEGER, ALLOCATABLE :: iqDescen(:) !--- Descendants index (in growing generation order) INTEGER :: nqDescen = 0 !--- Number of descendants (all generations) INTEGER :: nqChildren = 0 !--- Number of children (first generation) INTEGER :: iadv = 10 !--- Advection scheme used LOGICAL :: isAdvected = .FALSE. !--- "true" tracers: iadv > 0. COUNT(isAdvected )=nqtrue LOGICAL :: isInPhysics = .TRUE. !--- "true" tracers: in tr_seri. COUNT(isInPhysics)=nqtottr INTEGER :: iso_iGroup = 0 !--- Isotopes group index in isotopes(:) INTEGER :: iso_iName = 0 !--- Isotope name index in isotopes(iso_iGroup)%trac(:) INTEGER :: iso_iZone = 0 !--- Isotope zone index in isotopes(iso_iGroup)%zone(:) INTEGER :: iso_iPhase = 0 !--- Isotope phase index in isotopes(iso_iGroup)%phase END TYPE trac_type !------------------------------------------------------------------------------------------------------------------------------ TYPE :: isot_type !=== TYPE FOR AN ISOTOPES FAMILY DESCENDING ON TRACER "parent" CHARACTER(LEN=maxlen) :: parent !--- Isotopes family name (parent tracer name ; ex: H2O) TYPE(keys_type), ALLOCATABLE :: keys(:) !--- Isotopes keys/values pairs list (length: niso) LOGICAL :: check=.FALSE. !--- Flag for checking routines triggering CHARACTER(LEN=maxlen), ALLOCATABLE :: trac(:) !--- Isotopes + tagging tracers list (length: ntiso) CHARACTER(LEN=maxlen), ALLOCATABLE :: zone(:) !--- Geographic tagging zones names list (length: nzone) CHARACTER(LEN=maxlen) :: phase = 'g' !--- Phases list: [g][l][s] (length: nphas) INTEGER :: niso = 0 !--- Number of isotopes, excluding tagging tracers INTEGER :: ntiso = 0 !--- Number of isotopes, including tagging tracers INTEGER :: nzone = 0 !--- Number of geographic tagging zones INTEGER :: nphas = 0 !--- Number of phases INTEGER, ALLOCATABLE :: iqIsoPha(:,:) !--- Idx in "tracers(1:nqtot)" = f(name(1:ntiso)),phas) !--- (former name: "iqiso" INTEGER, ALLOCATABLE :: iqWIsoPha(:,:) !--- Idx in "tracers(1:nqtot)" = f(name(1:ntiso)),phas) !--- (former name: "?????") INTEGER, ALLOCATABLE :: itZonIso(:,:) !--- Idx in "trac(1:ntiso)" = f(zone, name(1:niso)) END TYPE isot_type !--- (former name: "index_trac") !------------------------------------------------------------------------------------------------------------------------------ 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_s1m, getKeyByName_sm, getKey_sm, & getKeyByName_i1, getKeyByName_i1m, getKeyByName_im, getKey_im, & getKeyByName_r1, getKeyByName_r1m, getKeyByName_rm, getKey_rm, & getKeyByName_l1, getKeyByName_l1m, getKeyByName_lm, getKey_lm END INTERFACE getKey !------------------------------------------------------------------------------------------------------------------------------ INTERFACE addKey MODULE PROCEDURE addKey_s11, addKey_s1m, addKey_smm, addKey_i11, addKey_i1m, addKey_imm, & addKey_r11, addKey_r1m, addKey_rmm, addKey_l11, addKey_l1m, addKey_lmm END INTERFACE addKey !------------------------------------------------------------------------------------------------------------------------------ INTERFACE isoSelect; MODULE PROCEDURE isoSelectByIndex, isoSelectByName; END INTERFACE isoSelect INTERFACE old2newH2O; MODULE PROCEDURE old2newH2O_1, old2newH2O_m; END INTERFACE old2newH2O INTERFACE new2oldH2O; MODULE PROCEDURE new2oldH2O_1, new2oldH2O_m; END INTERFACE new2oldH2O INTERFACE fGetKey; MODULE PROCEDURE fgetKeyIdx_s1, fgetKeyNam_s1; END INTERFACE fGetKey INTERFACE tracersSubset; MODULE PROCEDURE trSubset_Indx, trSubset_Name, trSubset_gen0Name; END INTERFACE tracersSubset INTERFACE idxAncestor; MODULE PROCEDURE idxAncestor_1, idxAncestor_m, idxAncestor_mt; END INTERFACE idxAncestor INTERFACE ancestor; MODULE PROCEDURE ancestor_1, ancestor_m, ancestor_mt; END INTERFACE ancestor INTERFACE addTracer; MODULE PROCEDURE addTracer_1, addTracer_1def; END INTERFACE addTracer INTERFACE delTracer; MODULE PROCEDURE delTracer_1, delTracer_1def; END INTERFACE delTracer 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 = 'vlirb' !--- Old phases for water (no separator) CHARACTER(LEN=maxlen), PARAMETER :: known_phases = 'glsrb' !--- 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 ','blownSnow'] CHARACTER(LEN=1), SAVE :: phases_sep = '_' !--- Phase separator CHARACTER(LEN=maxlen), SAVE :: isoFile = 'isotopes_params.def'!--- Name of the isotopes parameters file !--- CORRESPONDANCE BETWEEN OLD AND NEW WATER NAMES CHARACTER(LEN=maxlen), SAVE :: oldH2OIso(5) = ['eau', 'HDO', 'O18', 'O17', 'HTO' ] CHARACTER(LEN=maxlen), SAVE :: newH2OIso(5) = ['H216O', 'HDO ', 'H218O', 'H217O', 'HTO '] !--- CORRESPONDANCE BETWEEN OLD AND NEW HNO3 RELATED SPECIES NAMES (FOR REPROBUS) CHARACTER(LEN=maxlen), SAVE :: oldHNO3(2) = ['HNO3_g ', 'HNO3 '] CHARACTER(LEN=maxlen), SAVE :: newHNO3(2) = ['HNO3 ', 'HNO3tot'] !=== TRACERS AND ISOTOPES DESCRIPTORS, USED BY getKey TYPE(trac_type), ALLOCATABLE, TARGET, SAVE :: tracers(:) TYPE(isot_type), ALLOCATABLE, TARGET, SAVE :: isotopes(:) !=== ALIASES OF VARIABLES FROM SELECTED ISOTOPES FAMILY EMBEDDED IN "isotope" (isotopes(ixIso)) TYPE(isot_type), SAVE, POINTER :: isotope !--- CURRENTLY SELECTED ISOTOPES FAMILY DESCRIPTOR INTEGER, SAVE :: ixIso, iH2O=0 !--- Index of the selected isotopes family and H2O family INTEGER, SAVE :: nbIso !--- Number of isotopes classes LOGICAL, SAVE :: isoCheck !--- Flag to trigger the checking routines TYPE(keys_type), SAVE, POINTER :: isoKeys(:) !--- ONE SET OF KEYS FOR EACH ISOTOPE (LISTED IN isoName) CHARACTER(LEN=maxlen), SAVE, POINTER :: isoName(:), & !--- ISOTOPES NAMES FOR THE CURRENTLY SELECTED FAMILY isoZone(:), & !--- TAGGING ZONES FOR THE CURRENTLY SELECTED FAMILY isoPhas !--- USED PHASES FOR THE CURRENTLY SELECTED FAMILY INTEGER, SAVE :: niso, nzone, & !--- NUMBER OF ISOTOPES, TAGGING ZONES AND PHASES nphas, ntiso !--- NUMBER OF PHASES AND ISOTOPES + ISOTOPIC TAGGING TRACERS INTEGER, SAVE, POINTER ::itZonIso(:,:), & !--- INDEX IN "isoTrac" AS f(tagging zone idx, isotope idx) iqIsoPha(:,:), & !--- INDEX IN "qx" AS f(isotopic tracer idx, phase idx) iqWIsoPha(:,:) !--- INDEX IN "qx" AS f(isotopic tracer idx, phase idx) !=== PARAMETERS FOR DEFAULT BEHAVIOUR LOGICAL, PARAMETER :: lTracsMerge = .FALSE. !--- Merge/stack tracers lists LOGICAL, PARAMETER :: lSortByGen = .TRUE. !--- Sort by growing generation INTEGER, PARAMETER :: maxTableWidth = 192 !--- Maximum width of a table displayed with "dispTable" CHARACTER(LEN=maxlen) :: modname CONTAINS !============================================================================================================================== !============================================================================================================================== !=== READ ONE OR SEVERAL TRACER FILES AND FILL A "tr" TRACERS DESCRIPTOR DERIVED TYPE. !=== THE RETURNED 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, lRepr) RESULT(lerr) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=*), INTENT(IN) :: type_trac !--- List of components used LOGICAL, OPTIONAL, INTENT(IN) :: lRepr !--- Activate the HNNO3 exceptions for REPROBUS CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:), sections(:), trac_files(:) CHARACTER(LEN=maxlen) :: str, fname, tname, pname, cname INTEGER :: nsec, ierr, it, ntrac, ns, ip, ix, fType LOGICAL :: lRep TYPE(keys_type), POINTER :: k !------------------------------------------------------------------------------------------------------------------------------ lerr = .FALSE. modname = 'readTracersFiles' IF(.NOT.ALLOCATED(dBase)) ALLOCATE(dBase(0)) lRep=.FALSE.; IF(PRESENT(lRepr)) lRep = lRepr !--- Required sections + corresponding files names (new style single section case) for tests IF(test(testTracersFiles(modname, type_trac, fType, .FALSE., trac_files, sections), lerr)) RETURN nsec = SIZE(sections) !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 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: [] IF(ALLOCATED(tracers)) DEALLOCATE(tracers) ALLOCATE(tracers(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 lerr = strParse(str, ' ', s, 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) k => tracers(it)%keys !=== NAME OF THE TRACER tname = old2newH2O(s(3), ip) ix = strIdx(oldHNO3, s(3)) IF(ix /= 0 .AND. lRep) tname = newHNO3(ix) !--- Exception for HNO3 (REPROBUS ONLY) tracers(it)%name = tname !--- Set %name CALL addKey_s11('name', tname, k) !--- Set the name of the tracer tracers(it)%keys%name = tname !--- Copy tracers names in keys components !=== NAME OF THE COMPONENT cname = type_trac !--- Name of the model component IF(ANY([(addPhase('H2O', ip), ip = 1, nphases)] == tname)) cname = 'lmdz' tracers(it)%component = cname !--- Set %component CALL addKey_s11('component', cname, k) !--- Set the name of the model component !=== NAME OF THE PARENT pname = tran0 !--- Default name: default transporting fluid (air) IF(ns == 4) THEN pname = old2newH2O(s(4)) ix = strIdx(oldHNO3, s(4)) IF(ix /= 0 .AND. lRep) pname = newHNO3(ix) !--- Exception for HNO3 (REPROBUS ONLY) END IF tracers(it)%parent = pname !--- Set %parent CALL addKey_s11('parent', pname, k) !=== PHASE AND ADVECTION SCHEMES NUMBERS tracers(it)%phase = known_phases(ip:ip) !--- Set %phase: tracer phase (default: "g"azeous) CALL addKey_s11('phase', known_phases(ip:ip), k) !--- Set the phase of the tracer (default: "g"azeous) CALL addKey_s11('hadv', s(1), k) !--- Set the horizontal advection schemes number CALL addKey_s11('vadv', s(2), k) !--- Set the vertical advection schemes number END DO CLOSE(90) IF(test(setGeneration(tracers), lerr)) RETURN !--- Set %iGeneration and %gen0Name WHERE(tracers%iGeneration == 2) tracers(:)%type = 'tag' !--- Set %type: 'tracer' or 'tag' DO it=1,ntrac CALL addKey_s11('type', tracers(it)%type, tracers(it)%keys) !--- Set the type of tracer END DO IF(test(checkTracers(tracers, fname, fname), lerr)) RETURN !--- Detect orphans and check phases IF(test(checkUnique (tracers, fname, fname), lerr)) RETURN !--- Detect repeated tracers CALL sortTracers (tracers) !--- Sort the tracers !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CASE(2); IF(test(feedDBase(["tracer.def"], [type_trac], modname), lerr)) RETURN !=== SINGLE FILE, MULTIPLE SECTIONS !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CASE(3); IF(test(feedDBase( trac_files , sections, modname), lerr)) RETURN !=== MULTIPLE FILES, SINGLE SECTION !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ END SELECT !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(ALL([2,3] /= fType)) RETURN IF(nsec == 1) THEN; tracers = dBase(1)%trac ELSE IF(lTracsMerge) THEN CALL msg('The multiple required sections will be MERGED.', modname) IF(test(mergeTracers(dBase, tracers), lerr)) RETURN ELSE CALL msg('The multiple required sections will be CUMULATED.', modname) IF(test(cumulTracers(dBase, tracers), lerr)) RETURN END IF CALL setDirectKeys(tracers) !--- Set %iqParent, %iqDescen, %nqDescen, %nqChildren END FUNCTION readTracersFiles !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION testTracersFiles(modname, type_trac, fType, lDisp, tracf, sects) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: modname, type_trac INTEGER, INTENT(OUT) :: fType LOGICAL, OPTIONAL, INTENT(IN) :: lDisp CHARACTER(LEN=maxlen), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: tracf(:), sects(:) CHARACTER(LEN=maxlen), ALLOCATABLE :: trac_files(:), sections(:) LOGICAL, ALLOCATABLE :: ll(:) LOGICAL :: lD, lFound INTEGER :: is, nsec lD = .FALSE.; IF(PRESENT(lDisp)) lD = lDisp lerr = .FALSE. !--- PARSE "type_trac" LIST AND DETERMINE THE TRACERS FILES NAMES (FOR CASE 3: MULTIPLE FILES, SINGLE SECTION PER FILE) !--- If type_trac is a scalar (case 1), "sections" and "trac_files" are not usable, but are meaningless for case 1 anyway. IF(test(strParse(type_trac, '|', sections, n=nsec), lerr)) RETURN !--- Parse "type_trac" list IF(PRESENT(sects)) sects = sections ALLOCATE(trac_files(nsec), ll(nsec)) DO is=1, nsec trac_files(is) = 'tracer_'//TRIM(sections(is))//'.def' INQUIRE(FILE=TRIM(trac_files(is)), EXIST=ll(is)) END DO IF(PRESENT(tracf)) tracf = trac_files fType = 0 INQUIRE(FILE='traceur.def', EXIST=lFound); IF(lFound) fType = 1 !--- OLD STYLE FILE INQUIRE(FILE='tracer.def', EXIST=lFound); IF(lFound) fType = 2 !--- NEW STYLE ; SINGLE FILE, SEVERAL SECTIONS IF(ALL(ll)) fType = 3 !--- NEW STYLE ; SEVERAL FILES, SINGLE SECTION USED IF(.NOT.lD) RETURN !--- NO CHECKING/DISPLAY NEEDED: JUST GET type_trac,fType 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 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) END FUNCTION testTracersFiles !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION feedDBase(fnames, snames, modname) RESULT(lerr) ! Purpose: Read the sections "snames(is)" (pipe-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(:) !--- Pipe-deparated list of sections (one list each file) CHARACTER(LEN=*), INTENT(IN) :: modname !--- Calling routine name INTEGER, ALLOCATABLE :: ndb(:) !--- Number of sections for each file INTEGER, ALLOCATABLE :: ixf(:) !--- File index for each section of the expanded list CHARACTER(LEN=maxlen) :: 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) !--- 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 lerr = ANY([(dispTraSection('RAW CONTENT OF SECTION "'//TRIM(snm)//'"', snm, modname), idb=1, SIZE(dBase))]) IF(test(expandSection(dBase(idb)%trac, snm, fnm), lerr)) RETURN !--- EXPAND NAMES ; set %parent, %type, %component IF(test(setGeneration(dBase(idb)%trac), lerr)) RETURN !--- 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 lerr = ANY([(dispTraSection('EXPANDED CONTENT OF SECTION "'//TRIM(snm)//'"', snm, modname), idb=1, SIZE(dBase))]) !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ END DO !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ END FUNCTION feedDBase !------------------------------------------------------------------------------------------------------------------------------ !------------------------------------------------------------------------------------------------------------------------------ LOGICAL FUNCTION readSections(fnam,snam,defName) RESULT(lerr) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=*), INTENT(IN) :: fnam !--- File name CHARACTER(LEN=*), INTENT(IN) :: snam !--- Pipe-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 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, str2 CHARACTER(LEN=maxlen) :: secn INTEGER :: ierr, n !------------------------------------------------------------------------------------------------------------------------------ IF(.NOT.ALLOCATED(dBase)) ALLOCATE(dBase(0)) OPEN(90, FILE=fnam, FORM='formatted', STATUS='old') DO; str='' DO READ(90,'(a)', IOSTAT=ierr)str2 !--- Read a full line str=TRIM(str)//' '//TRIM(str2) !--- Append "str" with the current line n=LEN_TRIM(str); IF(n == 0) EXIT !--- Empty line (probably end of file) IF(IACHAR(str(n:n)) /= 92) EXIT !--- No "\" continuing line symbol found => end of line str = str(1:n-1) !--- Remove the "\" continuing line symbol END DO str = ADJUSTL(str) !--- Remove the front space 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,' ', s, n, v) !--- Parse = pairs tt = dBase(ndb)%trac(:) v(1) = s(1); s(1) = 'name' !--- Convert "name" into a regular key tmp%name = v(1); tmp%keys = keys_type(v(1), s(:), v(:)) !--- Set %name and %keys dBase(ndb)%trac = [tt(:), tmp] DEALLOCATE(tt) 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, .FALSE.) !--- Add key to all the tracers (no overwriting) DO it = 1, SIZE(t); CALL addKey_s11(ky%key(k), ky%val(k), t(it)%keys, .FALSE.); END DO 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 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 ! CALL addKey_s1m('component', sname, tr(:)%keys) DO iq=1,SIZE(tr); CALL addKey_s11('component', sname, tr(iq)%keys); END DO !--- 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 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ALLOCATE(ttr(nq)) iq = 1 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ DO it = 1, nt !=== EXPAND TRACERS AND PARENTS NAMES LISTS !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ll = strParse(tr(it)%name, ',', ta, ntr) !--- Number of tracers ll = strParse(tr(it)%parent, ',', pa, npr) !--- Number of parents DO ipr=1,npr !--- Loop on parents list elts DO itr=1,ntr !--- Loop on tracers list elts ttr(iq)%keys%key = tr(it)%keys%key ttr(iq)%keys%val = tr(it)%keys%val ttr(iq)%keys%name = ta(itr) ttr(iq)%name = TRIM(ta(itr)); CALL addKey_s11('name', ta(itr), ttr(iq)%keys) ttr(iq)%parent = TRIM(pa(ipr)); CALL addKey_s11('parent', pa(ipr), ttr(iq)%keys) ttr(iq)%type = tr(it)%type; CALL addKey_s11('type', tr(it)%type, ttr(iq)%keys) ttr(iq)%component = tr(it)%component; CALL addKey_s11('component', tr(it)%component, ttr(iq)%keys) iq = iq+1 END DO END DO !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ END DO !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ DEALLOCATE(ta,pa) CALL MOVE_ALLOC(FROM=ttr, TO=tr) END FUNCTION expandSection !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION setGeneration(tr) RESULT(lerr) !------------------------------------------------------------------------------------------------------------------------------ ! Purpose: Determine, for each tracer of "tr(:)": ! * %iGeneration: the generation number ! * %gen0Name: the generation 0 ancestor name ! Check also for orphan tracers (tracers not descending on "tran0"). !------------------------------------------------------------------------------------------------------------------------------ TYPE(trac_type), INTENT(INOUT) :: tr(:) !--- Tracer derived type vector INTEGER :: iq, jq, ig CHARACTER(LEN=maxlen), ALLOCATABLE :: parent(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: modname modname = 'setGeneration' IF(test(fmsg('missing "parent" attribute', modname, getKey('parent', parent, ky=tr(:)%keys)), lerr)) RETURN DO iq = 1, SIZE(tr) jq = iq; ig = 0 DO WHILE(parent(jq) /= tran0) jq = strIdx(tr(:)%name, parent(jq)) IF(test(fmsg('Orphan tracer "'//TRIM(tr(iq)%name)//'"', modname, jq == 0), lerr)) RETURN ig = ig + 1 END DO tr(iq)%gen0Name = tr(jq)%name; CALL addKey_s11('gen0Name', tr(iq)%gen0Name, tr(iq)%keys) tr(iq)%iGeneration = ig; CALL addKey_s11('iGeneration', TRIM(int2str(ig)), tr(iq)%keys) END DO END FUNCTION 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>0) THEN tdup(iq) = tnam !--- gen>0: 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". Phases are not repeated for a tracer, thanks to "checkUnique". !------------------------------------------------------------------------------------------------------------------------------ TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:) !--- Tracer derived type vector !------------------------------------------------------------------------------------------------------------------------------ TYPE(trac_type), ALLOCATABLE :: ttr(:) INTEGER, ALLOCATABLE :: i0(:) CHARACTER(LEN=maxlen) :: nam, pha, tname CHARACTER(LEN=1) :: p INTEGER :: ip, np, iq, jq, nq, it, nt, nc, i, n LOGICAL :: lTag, lExt !------------------------------------------------------------------------------------------------------------------------------ nq = SIZE(tr, DIM=1) nt = 0 DO iq = 1, nq !--- GET THE NUMBER OF TRACERS IF(tr(iq)%iGeneration /= 0) CYCLE !--- Only deal with generation 0 tracers nc = COUNT(tr(:)%gen0Name==tr(iq)%name .AND. tr%iGeneration/=0) !--- Number of children 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)) !--- Version of "tr" after phases expansion it = 1 !--- Current "ttr(:)" index DO iq = 1, nq !--- Loop on "tr(:)" indexes lTag = 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) lExt = np>1 !--- Phase suffix only required if phases number is > 1 IF(lTag) lExt = lExt .AND. tr(iq)%iGeneration>0 !--- No phase suffix for generation 0 tags DO i=1,n !=== LOOP ON GENERATION 0 ANCESTORS jq = i0(i) !--- tr(jq): ith tracer with same gen 0 ancestor as tr(iq) IF(tr(iq)%iGeneration==0) jq=iq !--- Generation 0: count the current tracer phases only pha = tr(jq)%phase !--- Phases list for tr(jq) DO ip = 1, LEN_TRIM(pha) !=== LOOP ON PHASES LISTS p = pha(ip:ip) tname = TRIM(tr(iq)%name); nam = tname !--- Tracer name (regular case) IF(lTag) nam = TRIM(tr(iq)%parent) !--- Parent name (tagging case) IF(lExt) nam = addPhase(nam, p ) !--- Phase extension needed IF(lTag) nam = TRIM(nam)//'_'//TRIM(tname) !--- _ 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 = p !--- Single phase entry CALL addKey_s11('name', nam, ttr(it)%keys) CALL addKey_s11('phase', p, ttr(it)%keys) IF(lExt .AND. tr(iq)%iGeneration>0) THEN ttr(it)%parent = addPhase(tr(iq)%parent, p) ttr(it)%gen0Name = addPhase(tr(iq)%gen0Name, p) CALL addKey_s11('parent', ttr(it)%parent, ttr(it)%keys) CALL addKey_s11('gen0Name', ttr(it)%gen0Name, ttr(it)%keys) END IF it = it+1 END DO IF(tr(iq)%iGeneration==0) EXIT !--- Break phase loop for gen 0 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 the beginning of the vector, in the "known_phases" order. ! * lGrowGen == T: in ascending generations numbers. ! * lGrowGen == F: tracer + its children 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 !------------------------------------------------------------------------------------------------------------------------------ TYPE(trac_type), ALLOCATABLE :: tr2(:) INTEGER, ALLOCATABLE :: iy(:), iz(:) INTEGER :: ig, ng, iq, jq, ip, nq, n, ix(SIZE(tr)), k ! tr2 is introduced in order to cope with a bug in gfortran 4.8.5 compiler !------------------------------------------------------------------------------------------------------------------------------ nq = SIZE(tr) DO ip = nphases, 1, -1 iq = strIdx(tr(:)%name, addPhase('H2O', ip)) IF(iq == 0) CYCLE tr2 = tr(:) tr = [tr2(iq), tr2(1:iq-1), tr2(iq+1:nq)] END DO IF(lSortByGen) THEN iq = 1 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 iq = 1 DO jq = 1, nq !--- Loop on generation 0 tracers IF(tr(jq)%iGeneration /= 0) CYCLE !--- Skip generations /= 0 ix(iq) = jq !--- Generation 0 ancestor index first iq = iq + 1 !--- Next "iq" for next generations tracers iy = strFind(tr(:)%gen0Name, TRIM(tr(jq)%name)) !--- Indexes of "tr(jq)" children in "tr(:)" ng = MAXVAL(tr(iy)%iGeneration, MASK=.TRUE., DIM=1) !--- Number of generations of the "tr(jq)" family DO ig = 1, ng !--- Loop on generations of 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 :: t(:) 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 !---------------------------------------------------------------------------------------------------------------------------- t => sections(is)%trac(:) !-------------------------------------------------------------------------------------------------------------------------- DO iq=1, nt(is) !=== LOOP ON TRACERS !-------------------------------------------------------------------------------------------------------------------------- tnam = TRIM(t(iq)%name) !--- Original name IF(COUNT(t%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, %nqChildren 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(:) CHARACTER(LEN=maxlen), ALLOCATABLE :: phas(:), prnt(:) TYPE(trac_type), POINTER :: tm(:) lerr = .FALSE. idb = strIdx(dBase(:)%name, sname); IF(idb == 0) RETURN tm => dBase(idb)%trac nq = SIZE(tm) !--- BEWARE ! Can't use the "getKeyByName" functions yet. ! Names must first include the phases for tracers defined on multiple lines. hadv = str2int(fgetKeys('hadv', tm(:)%keys, '10')) vadv = str2int(fgetKeys('vadv', tm(:)%keys, '10')) prnt = fgetKeys('parent',tm(:)%keys, '' ) IF(getKey('phases', phas, ky=tm(:)%keys)) phas = fGetKeys('phase', tm(:)%keys, 'g') CALL msg(TRIM(message)//':', modname) IF(ALL(prnt == 'air')) THEN IF(test(dispTable('iiiss', ['iq ','hadv ','vadv ','name ','phase '], cat(tm%name, phas), & cat([(iq, iq=1, nq)], hadv, vadv), nColMax=maxTableWidth, nHead=2, sub=modname), lerr)) RETURN ELSE IF(ALL(tm%iGeneration == -1)) THEN IF(test(dispTable('iiisss', ['iq ','hadv ','vadv ','name ','parent','phase '], cat(tm%name, prnt, phas), & cat([(iq, iq=1, nq)], hadv, vadv), nColMax=maxTableWidth, nHead=2, sub=modname), lerr)) RETURN ELSE IF(test(dispTable('iiissis', ['iq ','hadv ','vadv ','name ','parent','igen ','phase '], cat(tm%name, prnt, phas), & cat([(iq, iq=1, nq)], hadv, vadv, tm%iGeneration), nColMax=maxTableWidth, nHead=2, sub=modname), lerr)) RETURN END IF 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, igen, ngen, ix(SIZE(tr)) tr(:)%iqParent = strIdx( tr(:)%name, tr(:)%parent ) !--- Parent index DO iq = 1, SIZE(tr); CALL addKey_s11('iqParent', int2str(tr(iq)%iqParent), tr(iq)%keys); END DO ngen = MAXVAL(tr(:)%iGeneration, MASK=.TRUE.) DO iq = 1, SIZE(tr) ig = tr(iq)%iGeneration IF(ALLOCATED(tr(iq)%iqDescen)) DEALLOCATE(tr(iq)%iqDescen) ALLOCATE(tr(iq)%iqDescen(0)) CALL idxAncestor(tr, ix, ig) !--- Ancestor of generation "ng" for each tr DO igen = ig+1, ngen tr(iq)%iqDescen = [tr(iq)%iqDescen, find(ix==iq .AND. tr%iGeneration==igen)] tr(iq)%nqDescen = SIZE(tr(iq)%iqDescen) IF(igen == ig+1) THEN tr(iq)%nqChildren = tr(iq)%nqDescen CALL addKey_s11('nqChildren', int2str(tr(iq)%nqChildren), tr(iq)%keys) END IF END DO CALL addKey_s11('iqDescen', strStack(int2str(tr(iq)%iqDescen)), tr(iq)%keys) CALL addKey_s11('nqDescen', int2str(tr(iq)%nqDescen) , tr(iq)%keys) 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 (readIsotopes): ==== !=== parent, nzone, zone(:), niso, keys(:)%name, ntiso, trac(:), nphas, phas, iqIsoPha(:,:), itZonPhi(:,:) ==== !=== * 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_prv(fnam, isot) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: fnam !--- Input file name TYPE(isot_type), TARGET, INTENT(INOUT) :: isot(:) !--- Isotopes descriptors (field %parent must be defined!) LOGICAL :: lFound INTEGER :: is, iis, it, idb, ndb, nb0 CHARACTER(LEN=maxlen), ALLOCATABLE :: vals(:) CHARACTER(LEN=maxlen) :: modname TYPE(trac_type), POINTER :: tt(:), t TYPE(dataBase_type), ALLOCATABLE :: tdb(:) modname = 'readIsotopesFile' !--- THE INPUT FILE MUST BE PRESENT INQUIRE(FILE=TRIM(fnam), EXIST=lFound); lerr = .NOT.lFound IF(fmsg('Missing isotopes parameters file "'//TRIM(fnam)//'"', modname, 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 IF(test(ANY(reduceExpr(t%keys%val, vals)), lerr)) RETURN !--- Reduce expressions ; detect non-numerical elements isot(iis)%keys(is)%key = t%keys%key isot(iis)%keys(is)%val = vals END DO !--- CHECK FOR MISSING ISOTOPES (NO KEYS ALLOCATED) IF(test(checkList(isot(iis)%keys(:)%name, .NOT.[( ALLOCATED(isot(iis)%keys(is)%key), is=1, SIZE(isot(iis)%keys) )], & '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 !--- GET THE isoCheck ENTRY FROM THE *.DEF FILES (MIGHT BE CHANGED TO A CLASS-DEPENDANT KEYWORD) CALL get_in('ok_iso_verif', isot(strIdx(isot%parent, 'H2O'))%check, .FALSE.) lerr = dispIsotopes() CONTAINS !------------------------------------------------------------------------------------------------------------------------------ LOGICAL FUNCTION dispIsotopes() RESULT(lerr) INTEGER :: ik, nk, ip, it, nt CHARACTER(LEN=maxlen) :: prf CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:), val(:,:) CALL msg('Isotopes parameters read from file "'//TRIM(fnam)//'":', modname) DO ip = 1, SIZE(isot) !--- Loop on parents tracers nk = SIZE(isot(ip)%keys(1)%key) !--- Same keys for each isotope nt = SIZE(isot(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) = ['it ','name']; ttl(3:nk+2) = isot(ip)%keys(1)%key(:)!--- Titles line with keys names val(:,1) = isot(ip)%keys(:)%name !--- Values table 1st column: isotopes names DO ik = 1, nk DO it = 1, nt val(it,ik+1) = isot(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)', nColMax=maxTableWidth, nHead=2, sub=modname)), lerr)) RETURN DEALLOCATE(ttl, val) END DO END FUNCTION dispIsotopes !------------------------------------------------------------------------------------------------------------------------------ END FUNCTION readIsotopesFile_prv !============================================================================================================================== !============================================================================================================================== !=== IF ISOTOPES (2ND GENERATION TRACERS) ARE DETECTED: === !=== * COMPUTE MOST OF THE RELATED QUANTITIES ("isot" COMPONENTS). === !=== * COMPUTE FEW ISOTOPES-DEDICATED "trac" COMPONENTS === !=== * CALL readIsotopesFile_prv TO GET PHYSICAL QUANTITIES (= PAIRS) === !=== NOTE: THIS IS DONE HERE (IN A ROUTINE CALLED BY THE DYNAMIC), BECAUSE THE DYNAMIC NEEDS FEW PHYSICAL PARAMETERS. === !============================================================================================================================== LOGICAL FUNCTION readIsotopesFile(iNames) RESULT(lerr) CHARACTER(LEN=maxlen), TARGET, OPTIONAL, INTENT(IN) :: iNames(:) CHARACTER(LEN=maxlen), ALLOCATABLE :: p(:), str(:) !--- Temporary storage CHARACTER(LEN=maxlen) :: iName, modname CHARACTER(LEN=1) :: ph !--- Phase INTEGER :: ic, ip, iq, it, iz LOGICAL, ALLOCATABLE :: ll(:) !--- Mask TYPE(trac_type), POINTER :: t(:), t1 TYPE(isot_type), POINTER :: i lerr = .FALSE. modname = 'readIsotopesFile' t => tracers !--- GET FROM "tracers" THE FULL LIST OF AVAILABLE ISOTOPES CLASSES p = PACK(delPhase(t%parent), MASK = t%type=='tracer' .AND. t%iGeneration==1) CALL strReduce(p, nbIso) !--- CHECK WHETHER NEEDED ISOTOPES CLASSES "iNames" ARE AVAILABLE OR NOT IF(PRESENT(iNames)) THEN DO it = 1, SIZE(iNames) IF(test(fmsg('No isotopes class "'//TRIM(iNames(it))//'" found among tracers', modname, ALL(p /= iNames(it))), lerr)) RETURN END DO p = iNames; nbIso = SIZE(p) END IF IF(ALLOCATED(isotopes)) DEALLOCATE(isotopes) ALLOCATE(isotopes(nbIso)) IF(nbIso==0) RETURN !=== NO ISOTOPES: FINISHED !--- ISOTOPES RELATED VARIABLES ; NULL OR EMPTY IF NO ISOTOPES isotopes(:)%parent = p DO ic = 1, SIZE(p) !--- Loop on isotopes classes i => isotopes(ic) iname = i%parent !--- Current isotopes class name (parent tracer name) !=== Isotopes children 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" i%niso = SIZE(str) !--- Number of "effectively found isotopes of "iname" ALLOCATE(i%keys(i%niso)) FORALL(it = 1:i%niso) i%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 == 2 i%zone = PACK(strTail(t(:)%name,'_',.TRUE.), MASK = ll) !--- Tagging zones names for isotopes category "iname" CALL strReduce(i%zone) i%nzone = SIZE(i%zone) !--- Tagging zones number for isotopes category "iname" !=== Geographic tracers of the isotopes children 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) i%ntiso = i%niso + SIZE(str) !--- Number of isotopes + their geographic tracers [ntiso] ALLOCATE(i%trac(i%ntiso)) FORALL(it = 1:i%niso) i%trac(it) = i%keys(it)%name FORALL(it = i%niso+1:i%ntiso) i%trac(it) = str(it-i%niso) !=== Phases for tracer "iname" i%phase = '' DO ip = 1, nphases; ph = known_phases(ip:ip); IF(strIdx(t%name,addPhase(iname, ph)) /= 0) i%phase = TRIM(i%phase)//ph; END DO i%nphas = LEN_TRIM(i%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 => tracers(iq) IF(delPhase(t1%gen0Name)/=iname .OR. t1%iGeneration==0) CYCLE !--- Only deal with tracers descending on "iname" t1%iso_iGroup = ic !--- Isotopes family idx in list "isotopes(:)%parent" t1%iso_iName = strIdx(i%trac, strHead(delPhase(t1%name),'_',.TRUE.)) !--- Current isotope idx in effective isotopes list t1%iso_iZone = strIdx(i%zone, strTail(t1%name, '_',.TRUE.)) !--- Current isotope zone idx in effective zones list t1%iso_iPhase = INDEX(i%phase,TRIM(t1%phase)) !--- Current isotope phase idx in effective phases list IF(t1%iGeneration /= 2) t1%iso_iZone = 0 !--- Skip possible generation 1 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 i%iqIsoPha = RESHAPE( [( (strIdx(t%name, addPhase(i%trac(it),i%phase(ip:ip))), it=1, i%ntiso), ip=1, i%nphas)], & [i%ntiso, i%nphas] ) !=== Table used to get iq (index in dyn array, size nqtot) from the water and 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 i%iqWIsoPha = RESHAPE( [( [strIdx(t%name, addPhase('H2O',i%phase(ip:ip))), i%iqIsoPha(:,ip)], ip=1,i%nphas)], & [1+i%ntiso, i%nphas] ) !=== Table used to get ix (index in tagging tracers isotopes list, size ntiso) from the zone and isotope indexes i%itZonIso = RESHAPE( [( (strIdx(i%trac(:), TRIM(i%trac(it))//'_'//TRIM(i%zone(iz))), iz=1, i%nzone), it=1, i%niso )], & [i%nzone, i%niso] ) END DO !=== READ PHYSICAL PARAMETERS FROM isoFile FILE ! IF(test(readIsotopesFile_prv(isoFile, isotopes), lerr)) RETURN! on commente pour ne pas chercher isotopes_params.def !=== CHECK CONSISTENCY IF(test(testIsotopes(), lerr)) RETURN !=== SELECT FIRST ISOTOPES CLASS OR, IF POSSIBLE, WATER CLASS IF(.NOT.test(isoSelect(1, .TRUE.), lerr)) THEN; IF(isotope%parent == 'H2O') iH2O = ixIso; END IF CONTAINS !------------------------------------------------------------------------------------------------------------------------------ LOGICAL FUNCTION testIsotopes() RESULT(lerr) !--- MAKE SURE MEMBERS OF AN ISOTOPES FAMILY ARE PRESENT IN THE SAME PHASES !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: ix, it, ip, np, iz, nz TYPE(isot_type), POINTER :: i DO ix = 1, nbIso i => isotopes(ix) !--- Check whether each isotope and tagging isotopic tracer is present in the same number of phases DO it = 1, i%ntiso np = SUM([(COUNT(tracers(:)%name == addPhase(i%trac(it), i%phase(ip:ip))), ip=1, i%nphas)]) IF(test(fmsg(TRIM(int2str(np))//' phases instead of '//TRIM(int2str(i%nphas))//' for '//TRIM(i%trac(it)), & modname, np /= i%nphas), lerr)) RETURN END DO DO it = 1, i%niso nz = SUM([(COUNT(i%trac == TRIM(i%trac(it))//'_'//i%zone(iz)), iz=1, i%nzone)]) IF(test(fmsg(TRIM(int2str(nz))//' tagging zones instead of '//TRIM(int2str(i%nzone))//' for '//TRIM(i%trac(it)), & modname, nz /= i%nzone), lerr)) RETURN END DO END DO END FUNCTION testIsotopes !------------------------------------------------------------------------------------------------------------------------------ END FUNCTION readIsotopesFile !============================================================================================================================== !============================================================================================================================== !=== THE ROUTINE isoSelect IS USED TO SWITCH FROM AN ISOTOPE FAMILY TO ANOTHER: ISOTOPES DEPENDENT PARAMETERS ARE UPDATED ! Single generic "isoSelect" routine, using the predefined index of the parent (fast version) or its name (first call). !============================================================================================================================== LOGICAL FUNCTION isoSelectByName(iName, lVerbose) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: iName LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose INTEGER :: iIso LOGICAL :: lV lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose iIso = strIdx(isotopes(:)%parent, iName) IF(test(iIso == 0, lerr)) THEN niso = 0; ntiso = 0; nzone = 0; nphas = 0; isoCheck=.FALSE. CALL msg('no isotope family named "'//TRIM(iName)//'"', ll=lV) RETURN END IF lerr = isoSelectByIndex(iIso, lV) END FUNCTION isoSelectByName !============================================================================================================================== LOGICAL FUNCTION isoSelectByIndex(iIso, lVerbose) RESULT(lerr) IMPLICIT NONE INTEGER, INTENT(IN) :: iIso LOGICAL, OPTIONAL, INTENT(IN) :: lVerbose LOGICAL :: lV lv = .FALSE.; IF(PRESENT(lVerbose)) lv = lVerbose lerr = .FALSE. IF(iIso == ixIso) RETURN !--- Nothing to do if the index is already OK lerr = iIso<=0 .OR. iIso>SIZE(isotopes) CALL msg('Inconsistent isotopes family index '//TRIM(int2str(iIso))//': should be > 0 and <= '& //TRIM(int2str(SIZE(isotopes)))//'"', ll = lerr .AND. lV) IF(lerr) RETURN ixIso = iIso !--- Update currently selected family index isotope => isotopes(ixIso) !--- Select corresponding component isoKeys => isotope%keys; niso = isotope%niso isoName => isotope%trac; ntiso = isotope%ntiso isoZone => isotope%zone; nzone = isotope%nzone isoPhas => isotope%phase; nphas = isotope%nphas itZonIso => isotope%itZonIso; isoCheck = isotope%check iqIsoPha => isotope%iqIsoPha iqWIsoPha => isotope%iqWIsoPha END FUNCTION isoSelectByIndex !============================================================================================================================== !============================================================================================================================== !=== ADD THE = PAIR TO THE "ky[(:)]" KEY[S] DESCRIPTOR[S] OR THE = PAIRS TO THE "ky(:)" KEYS DESCRIPTORS !============================================================================================================================== SUBROUTINE addKey_s11(key, sval, ky, lOverWrite) CHARACTER(LEN=*), INTENT(IN) :: key, sval TYPE(keys_type), INTENT(INOUT) :: ky LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: k(:), v(:) INTEGER :: iky, nky LOGICAL :: lo lo=.TRUE.; IF(PRESENT(lOverWrite)) lo=lOverWrite IF(.NOT.ALLOCATED(ky%key)) THEN ALLOCATE(ky%key(1)); ky%key(1)=key ALLOCATE(ky%val(1)); ky%val(1)=sval RETURN END IF iky = strIdx(ky%key,key) IF(iky == 0) THEN nky = SIZE(ky%key) ALLOCATE(k(nky+1)); k(1:nky) = ky%key; k(nky+1) = key; ky%key = k ALLOCATE(v(nky+1)); v(1:nky) = ky%val; v(nky+1) = sval; ky%val = v ELSE IF(lo) THEN ky%key(iky) = key; ky%val(iky) = sval END IF END SUBROUTINE addKey_s11 !============================================================================================================================== SUBROUTINE addKey_i11(key, ival, ky, lOverWrite) CHARACTER(LEN=*), INTENT(IN) :: key INTEGER, INTENT(IN) :: ival TYPE(keys_type), INTENT(INOUT) :: ky LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite !------------------------------------------------------------------------------------------------------------------------------ CALL addKey_s11(key, int2str(ival), ky, lOverWrite) END SUBROUTINE addKey_i11 !============================================================================================================================== SUBROUTINE addKey_r11(key, rval, ky, lOverWrite) CHARACTER(LEN=*), INTENT(IN) :: key REAL, INTENT(IN) :: rval TYPE(keys_type), INTENT(INOUT) :: ky LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite !------------------------------------------------------------------------------------------------------------------------------ CALL addKey_s11(key, real2str(rval), ky, lOverWrite) END SUBROUTINE addKey_r11 !============================================================================================================================== SUBROUTINE addKey_l11(key, lval, ky, lOverWrite) CHARACTER(LEN=*), INTENT(IN) :: key LOGICAL, INTENT(IN) :: lval TYPE(keys_type), INTENT(INOUT) :: ky LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite !------------------------------------------------------------------------------------------------------------------------------ CALL addKey_s11(key, bool2str(lval), ky, lOverWrite) END SUBROUTINE addKey_l11 !============================================================================================================================== !============================================================================================================================== SUBROUTINE addKey_s1m(key, sval, ky, lOverWrite) CHARACTER(LEN=*), INTENT(IN) :: key, sval TYPE(keys_type), INTENT(INOUT) :: ky(:) LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: itr DO itr = 1, SIZE(ky) CALL addKey_s11(key, sval, ky(itr), lOverWrite) END DO END SUBROUTINE addKey_s1m !============================================================================================================================== SUBROUTINE addKey_i1m(key, ival, ky, lOverWrite) CHARACTER(LEN=*), INTENT(IN) :: key INTEGER, INTENT(IN) :: ival TYPE(keys_type), INTENT(INOUT) :: ky(:) LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: itr DO itr = 1, SIZE(ky) CALL addKey_s11(key, int2str(ival), ky(itr), lOverWrite) END DO END SUBROUTINE addKey_i1m !============================================================================================================================== SUBROUTINE addKey_r1m(key, rval, ky, lOverWrite) CHARACTER(LEN=*), INTENT(IN) :: key REAL, INTENT(IN) :: rval TYPE(keys_type), INTENT(INOUT) :: ky(:) LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: itr DO itr = 1, SIZE(ky) CALL addKey_s11(key, real2str(rval), ky(itr), lOverWrite) END DO END SUBROUTINE addKey_r1m !============================================================================================================================== SUBROUTINE addKey_l1m(key, lval, ky, lOverWrite) CHARACTER(LEN=*), INTENT(IN) :: key LOGICAL, INTENT(IN) :: lval TYPE(keys_type), INTENT(INOUT) :: ky(:) LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: itr DO itr = 1, SIZE(ky) CALL addKey_s11(key, bool2str(lval), ky(itr), lOverWrite) END DO END SUBROUTINE addKey_l1m !============================================================================================================================== !============================================================================================================================== SUBROUTINE addKey_smm(key, sval, ky, lOverWrite) CHARACTER(LEN=*), INTENT(IN) :: key, sval(:) TYPE(keys_type), INTENT(INOUT) :: ky(:) LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: itr DO itr = 1, SIZE(ky); CALL addKey_s11(key, sval(itr), ky(itr), lOverWrite); END DO END SUBROUTINE addKey_smm !============================================================================================================================== SUBROUTINE addKey_imm(key, ival, ky, lOverWrite) CHARACTER(LEN=*), INTENT(IN) :: key INTEGER, INTENT(IN) :: ival(:) TYPE(keys_type), INTENT(INOUT) :: ky(:) LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: itr DO itr = 1, SIZE(ky); CALL addKey_s11(key, int2str(ival(itr)), ky(itr), lOverWrite); END DO END SUBROUTINE addKey_imm !============================================================================================================================== SUBROUTINE addKey_rmm(key, rval, ky, lOverWrite) CHARACTER(LEN=*), INTENT(IN) :: key REAL, INTENT(IN) :: rval(:) TYPE(keys_type), INTENT(INOUT) :: ky(:) LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: itr DO itr = 1, SIZE(ky); CALL addKey_s11(key, real2str(rval(itr)), ky(itr), lOverWrite); END DO END SUBROUTINE addKey_rmm !============================================================================================================================== SUBROUTINE addKey_lmm(key, lval, ky, lOverWrite) CHARACTER(LEN=*), INTENT(IN) :: key LOGICAL, INTENT(IN) :: lval(:) TYPE(keys_type), INTENT(INOUT) :: ky(:) LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: itr DO itr = 1, SIZE(ky); CALL addKey_s11(key, bool2str(lval(itr)), ky(itr), lOverWrite); END DO END SUBROUTINE addKey_lmm !============================================================================================================================== !============================================================================================================================== !=== OVERWRITE THE KEYS OF THE TRACER NAMED "tr0" WITH THE VALUES FOUND IN THE *.def FILES, IF ANY. =========================== !============================================================================================================================== SUBROUTINE addKeysFromDef(t, tr0) 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, '*none*') IF(val /= '*none*') CALL addKey_s11(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.) END DO END SUBROUTINE addKeysFromDef !============================================================================================================================== !============================================================================================================================== !=== REMOVE THE KEYS NAMED "keyn(:)" FROM EITHER THE "itr"th OR ALL THE KEYS DESCRIPTORS OF "ky(:)" =========================== !============================================================================================================================== SUBROUTINE delKey_1(itr, keyn, ky) 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) 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 !============================================================================================================================== !============================================================================================================================== !================ GET THE VALUE OF A KEY FROM A "keys_type" DERIVED TYPE ; THE RESULT IS THE RETURNED VALUE =================== !============================================================================================================================== CHARACTER(LEN=maxlen) FUNCTION fgetKeyIdx_s1(itr, keyn, ky, def_val, lerr) RESULT(val) INTEGER, INTENT(IN) :: itr CHARACTER(LEN=*), INTENT(IN) :: keyn TYPE(keys_type), INTENT(IN) :: ky(:) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def_val LOGICAL, OPTIONAL, INTENT(OUT) :: lerr !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: iky LOGICAL :: ler iky = 0; val = '' IF(.NOT.test(itr <= 0 .OR. itr > SIZE(ky), ler)) iky = strIdx(ky(itr)%key(:), keyn) !--- Correct index IF(.NOT.test(iky == 0, ler)) val = ky(itr)%val(iky) !--- Found key IF(iky == 0) THEN IF(.NOT.test(.NOT.PRESENT(def_val), ler)) val = def_val !--- Default value END IF IF(PRESENT(lerr)) lerr = ler END FUNCTION fgetKeyIdx_s1 !============================================================================================================================== CHARACTER(LEN=maxlen) FUNCTION fgetKeyNam_s1(tname, keyn, ky, def_val, lerr) RESULT(val) CHARACTER(LEN=*), INTENT(IN) :: tname, keyn TYPE(keys_type), INTENT(IN) :: ky(:) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def_val LOGICAL, OPTIONAL, INTENT(OUT) :: lerr !------------------------------------------------------------------------------------------------------------------------------ val = fgetKeyIdx_s1(strIdx(ky(:)%name, tname), keyn, ky, def_val, lerr) END FUNCTION fgetKeyNam_s1 !============================================================================================================================== FUNCTION fgetKeys(keyn, ky, def_val, lerr) RESULT(val) CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:) CHARACTER(LEN=*), INTENT(IN) :: keyn TYPE(keys_type), INTENT(IN) :: ky(:) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: def_val LOGICAL, OPTIONAL, INTENT(OUT) :: lerr !------------------------------------------------------------------------------------------------------------------------------ LOGICAL :: ler(SIZE(ky)) INTEGER :: it val = [(fgetKeyIdx_s1(it, keyn, ky, def_val, ler(it)), it = 1, SIZE(ky))] IF(PRESENT(lerr)) lerr = ANY(ler) END FUNCTION fgetKeys !============================================================================================================================== !============================================================================================================================== !========== GET THE VALUE OF A KEY FROM A "keys_type" DERIVED TYPE ; THE RETURNED VALUE IS THE ERROR CODE ============== !========== The key "keyn" is searched in: 1) "ky(:)%name" (if given) ============== !========== 2) "tracers(:)%name" ============== !========== 3) "isotope%keys(:)%name" ============== !========== for the tracer[s] "tname[(:)]" (if given) or all the available tracers from the used set otherwise. ============== !========== The type of the returned value(s) can be string, integer or real, scalar or vector ============== !============================================================================================================================== LOGICAL FUNCTION getKeyByName_s1(keyn, val, tname, ky) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn CHARACTER(LEN=maxlen), INTENT(OUT) :: val CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: tnam tnam = strHead(delPhase(tname),'_',.TRUE.) !--- Remove phase and tag IF(PRESENT(ky)) THEN !=== KEY FROM "ky" val = fgetKeyNam_s1(tname, keyn, ky, lerr=lerr) !--- "ky" and "tname" IF( lerr ) val = fgetKeyNam_s1(tnam, keyn, ky, lerr=lerr) !--- "ky" and "tnam" ELSE IF( .NOT.test(.NOT.ALLOCATED(tracers ), lerr)) lerr = SIZE(tracers ) == 0 !=== KEY FROM "tracers" IF(.NOT.lerr) THEN val = fgetKeyNam_s1(tname, keyn, tracers%keys, lerr=lerr) !--- "ky" and "tname" IF(lerr) val = fgetKeyNam_s1(tnam, keyn, tracers%keys, lerr=lerr) !--- "ky" and "tnam" END IF IF(lerr.AND..NOT.test(.NOT.ALLOCATED(isotopes), lerr)) lerr = SIZE(isotopes) == 0 !=== KEY FROM "isotope" IF(.NOT.lerr) THEN val = fgetKeyNam_s1(tname, keyn, isotope%keys, lerr=lerr) !--- "ky" and "tname" IF(lerr) val = fgetKeyNam_s1(tnam, keyn, isotope%keys, lerr=lerr) !--- "ky" and "tnam" END IF END IF END FUNCTION getKeyByName_s1 !============================================================================================================================== LOGICAL FUNCTION getKeyByName_s1m(keyn, val, tname, ky) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: sval lerr = getKeyByName_s1(keyn, sval, tname, ky) IF(test(fmsg('missing key "'//TRIM(keyn)//'" for tracer "'//TRIM(tname)//'"', modname, lerr), lerr)) RETURN lerr = strParse(sval, ',', val) END FUNCTION getKeyByName_s1m !============================================================================================================================== LOGICAL FUNCTION getKeyByName_sm(keyn, val, tname, ky, nam) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) CHARACTER(LEN=*), INTENT(IN) :: tname(:) TYPE(keys_type), OPTIONAL, TARGET, INTENT(IN) :: ky(:) CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) !------------------------------------------------------------------------------------------------------------------------------ TYPE(keys_type), POINTER :: keys(:) LOGICAL :: lk, lt, li INTEGER :: iq, nq !--- DETERMINE THE DATABASE TO BE USED (ky, tracers or isotope) lk = PRESENT(ky) lt = .NOT.lk .AND. ALLOCATED(tracers); IF(lt) lt = SIZE(tracers) /= 0; IF(lt) lt = ANY(tracers(1)%keys%key(:) == keyn) li = .NOT.lt .AND. ALLOCATED(isotopes); IF(li) li = SIZE(isotopes) /= 0; IF(li) li = ANY(isotope%keys(1)%key(:) == keyn) !--- LINK "keys" TO THE RIGHT DATABASE IF(test(.NOT.ANY([lk,lt,li]), lerr)) RETURN IF(lk) keys => ky(:) IF(lt) keys => tracers(:)%keys IF(li) keys => isotope%keys(:) !--- GET THE DATA nq = SIZE(tname) ALLOCATE(val(nq)) lerr = ANY([(getKeyByName_s1(keyn, val(iq), tname(iq), keys(:)), iq=1, nq)]) IF(PRESENT(nam)) nam = tname(:) END FUNCTION getKeyByName_sm !============================================================================================================================== LOGICAL FUNCTION getKey_sm(keyn, val, ky, nam) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) !------------------------------------------------------------------------------------------------------------------------------ ! Note: if names are repeated, getKeyByName_sm can't be used ; this routine, using indexes, must be used instead. IF(PRESENT(ky)) THEN !=== KEY FROM "ky" val = fgetKeys(keyn, ky, lerr=lerr) IF(PRESENT(nam)) nam = ky(:)%name ELSE IF( .NOT.test(.NOT.ALLOCATED(tracers ), lerr)) lerr = SIZE(tracers ) == 0 !=== KEY FROM "tracers" IF(.NOT.lerr) val = fgetKeys(keyn, tracers%keys, lerr=lerr) IF(.NOT.lerr.AND.PRESENT(nam)) nam = tracers(:)%keys%name IF(lerr.AND..NOT.test(.NOT.ALLOCATED(isotopes), lerr)) lerr = SIZE(isotopes) == 0 !=== KEY FROM "isotope" IF(.NOT.lerr) val = fgetKeys(keyn, isotope%keys, lerr=lerr) IF(.NOT.lerr.AND.PRESENT(nam)) nam = isotope%keys(:)%name END IF END FUNCTION getKey_sm !============================================================================================================================== LOGICAL FUNCTION getKeyByName_i1(keyn, val, tname, ky) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn INTEGER, INTENT(OUT) :: val CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: sval INTEGER :: ierr lerr = getKeyByName_s1(keyn, sval, tname, ky) IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tname)//'" is missing', modname, lerr), lerr)) RETURN READ(sval, *, IOSTAT=ierr) val IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not an integer', modname, ierr/=0), lerr)) RETURN END FUNCTION getKeyByName_i1 !============================================================================================================================== LOGICAL FUNCTION getKeyByName_i1m(keyn, val, tname, ky) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:) CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:) INTEGER :: ierr, iq, nq IF(test(getKeyByName_s1m(keyn, sval, tname, ky), lerr)) RETURN nq = SIZE(sval); ALLOCATE(val(nq)) lerr = .FALSE.; DO iq=1, nq; READ(sval(iq), *, IOSTAT=ierr) val(iq); lerr = lerr .OR. ierr /= 0; END DO IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not an integer', modname, lerr), lerr)) RETURN END FUNCTION getKeyByName_i1m !============================================================================================================================== LOGICAL FUNCTION getKeyByName_im(keyn, val, tname, ky, nam) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:) CHARACTER(LEN=*), INTENT(IN) :: tname(:) TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:) INTEGER :: ierr, iq, nq IF(test(getKeyByName_sm(keyn, sval, tname, ky, names), lerr)) RETURN nq = SIZE(sval); ALLOCATE(val(nq)) DO iq = 1, nq !--- CONVERT THE KEYS TO INTEGERS READ(sval(iq), *, IOSTAT=ierr) val(iq) IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not an integer', modname, ierr/=0), lerr)) RETURN END DO IF(PRESENT(nam)) nam = names(:) END FUNCTION getKeyByName_im !============================================================================================================================== LOGICAL FUNCTION getKey_im(keyn, val, ky, nam) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn INTEGER, ALLOCATABLE, INTENT(OUT) :: val(:) TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:) INTEGER :: ierr, iq, nq IF(test(getKey_sm(keyn, sval, ky, names), lerr)) RETURN nq = SIZE(sval); ALLOCATE(val(nq)) DO iq = 1, nq READ(sval(iq), *, IOSTAT=ierr) val(iq) IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not an integer', modname, ierr/=0), lerr)) RETURN END DO IF(PRESENT(nam)) nam = names END FUNCTION getKey_im !============================================================================================================================== LOGICAL FUNCTION getKeyByName_r1(keyn, val, tname, ky) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn REAL, INTENT(OUT) :: val CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: sval INTEGER :: ierr lerr = getKeyByName_s1(keyn, sval, tname, ky) IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tname)//'" is missing', modname, lerr), lerr)) RETURN READ(sval, *, IOSTAT=ierr) val IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not a real', modname, ierr/=0), lerr)) RETURN END FUNCTION getKeyByName_r1 !============================================================================================================================== LOGICAL FUNCTION getKeyByName_r1m(keyn, val, tname, ky) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn REAL, ALLOCATABLE, INTENT(OUT) :: val(:) CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:) INTEGER :: ierr, iq, nq IF(test(getKeyByName_s1m(keyn, sval, tname, ky), lerr)) RETURN nq = SIZE(sval); ALLOCATE(val(nq)) lerr = .FALSE.; DO iq=1, nq; READ(sval(iq), *, IOSTAT=ierr) val(iq); lerr = lerr .OR. ierr /= 0; END DO IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not a vector of reals', modname, lerr), lerr)) RETURN END FUNCTION getKeyByName_r1m !============================================================================================================================== LOGICAL FUNCTION getKeyByName_rm(keyn, val, tname, ky, nam) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn REAL, ALLOCATABLE, INTENT(OUT) :: val(:) CHARACTER(LEN=*), INTENT(IN) :: tname(:) TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:) INTEGER :: ierr, iq, nq IF(test(getKeyByName_sm(keyn, sval, tname, ky, names), lerr)) RETURN nq = SIZE(sval); ALLOCATE(val(nq)) DO iq = 1, nq !--- CONVERT THE KEYS TO INTEGERS READ(sval(iq), *, IOSTAT=ierr) val(iq) IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not a real', modname, ierr/=0), lerr)) RETURN END DO IF(PRESENT(nam)) nam = names END FUNCTION getKeyByName_rm !============================================================================================================================== LOGICAL FUNCTION getKey_rm(keyn, val, ky, nam) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: keyn REAL, ALLOCATABLE, INTENT(OUT) :: val(:) TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:) INTEGER :: ierr, iq, nq IF(test(getKey_sm(keyn, sval, ky, names), lerr)) RETURN nq = SIZE(sval); ALLOCATE(val(nq)) DO iq = 1, nq !--- CONVERT THE KEYS TO INTEGERS READ(sval(iq), *, IOSTAT=ierr) val(iq) IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not a real', modname, ierr/=0), lerr)) RETURN END DO IF(PRESENT(nam)) nam = names END FUNCTION getKey_rm !============================================================================================================================== LOGICAL FUNCTION getKeyByName_l1(keyn, val, tname, ky) RESULT(lerr) USE strings_mod, ONLY: str2bool CHARACTER(LEN=*), INTENT(IN) :: keyn LOGICAL, INTENT(OUT) :: val CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: sval lerr = getKeyByName_s1(keyn, sval, tname, ky) IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tname)//'" is missing', modname, lerr), lerr)) RETURN val = str2bool(sval) END FUNCTION getKeyByName_l1 !============================================================================================================================== LOGICAL FUNCTION getKeyByName_l1m(keyn, val, tname, ky) RESULT(lerr) USE strings_mod, ONLY: str2bool CHARACTER(LEN=*), INTENT(IN) :: keyn LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:) CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:) INTEGER :: iq, nq IF(test(getKeyByName_s1m(keyn, sval, tname, ky), lerr)) RETURN nq = SIZE(sval); ALLOCATE(val(nq)) lerr = .FALSE.; DO iq=1, nq; val(iq)=str2bool(sval(iq)); END DO END FUNCTION getKeyByName_l1m !============================================================================================================================== LOGICAL FUNCTION getKeyByName_lm(keyn, val, tname, ky, nam) RESULT(lerr) USE strings_mod, ONLY: str2bool CHARACTER(LEN=*), INTENT(IN) :: keyn LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:) CHARACTER(LEN=*), INTENT(IN) :: tname(:) TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:) INTEGER :: iq, nq IF(test(getKeyByName_sm(keyn, sval, tname, ky, nam), lerr)) RETURN nq = SIZE(sval); ALLOCATE(val(nq)) lerr = .FALSE.; DO iq=1, nq; val(iq)=str2bool(sval(iq)); END DO END FUNCTION getKeyByName_lm !============================================================================================================================== LOGICAL FUNCTION getKey_lm(keyn, val, ky, nam) RESULT(lerr) USE strings_mod, ONLY: str2bool CHARACTER(LEN=*), INTENT(IN) :: keyn LOGICAL, ALLOCATABLE, INTENT(OUT) :: val(:) TYPE(keys_type), OPTIONAL, INTENT(IN) :: ky(:) CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:) INTEGER :: iq, nq IF(test(getKey_sm(keyn, sval, ky, nam), lerr)) RETURN nq = SIZE(sval); ALLOCATE(val(nq)) lerr = .FALSE.; DO iq=1, nq; val(iq)=str2bool(sval(iq)); END DO END FUNCTION getKey_lm !============================================================================================================================== !============================================================================================================================== !=== ROUTINES TO GET OR PUT TRACERS AND ISOTOPES DATABASES, SINCE tracers AND isotopes ARE PRIVATE VARIABLES ================== !============================================================================================================================== SUBROUTINE setKeysDBase(tracers_, isotopes_, isotope_) TYPE(trac_type), OPTIONAL, INTENT(IN) :: tracers_(:) TYPE(isot_type), OPTIONAL, INTENT(IN) :: isotopes_(:) TYPE(isot_type), OPTIONAL, INTENT(IN) :: isotope_ !------------------------------------------------------------------------------------------------------------------------------ TYPE(isot_type), ALLOCATABLE :: iso(:) INTEGER :: ix, nbIso IF(PRESENT( tracers_)) THEN; tracers = tracers_; ELSE; ALLOCATE( tracers(0)); END IF IF(PRESENT(isotopes_)) THEN; isotopes = isotopes_; ELSE; ALLOCATE(isotopes(0)); END IF IF(PRESENT(isotope_ )) THEN ix = strIdx(isotopes(:)%parent, isotope_%parent) IF(ix /= 0) THEN isotopes(ix) = isotope_ ELSE nbIso = SIZE(isotopes); ALLOCATE(iso(nbIso+1)); iso(1:nbIso) = isotopes; iso(nbIso+1) = isotope_ CALL MOVE_ALLOC(FROM=iso, TO=isotopes) END IF END IF END SUBROUTINE setKeysDBase !============================================================================================================================== SUBROUTINE getKeysDBase(tracers_, isotopes_, isotope_) TYPE(trac_type), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: tracers_(:) TYPE(isot_type), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: isotopes_(:) TYPE(isot_type), OPTIONAL, INTENT(OUT) :: isotope_ !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: ix IF(PRESENT( tracers_)) THEN; tracers_ = tracers; ELSE; ALLOCATE( tracers_(0)); END IF IF(PRESENT(isotopes_)) THEN; isotopes_ = isotopes; ELSE; ALLOCATE(isotopes_(0)); END IF IF(PRESENT(isotope_ )) THEN; ix = strIdx(isotopes(:)%parent, isotope%parent); IF(ix /= 0) isotope_=isotopes(ix); END IF END SUBROUTINE getKeysDBase !============================================================================================================================== !============================================================================================================================== !=== 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 :: ix, ip, ns out = s; ns = LEN_TRIM(s) IF(s == '' .OR. ns<=2) RETURN !--- Empty string or LEN(name)<=2: nothing to do IF(s(1:3)=='H2O' .AND. INDEX(old_phases,s(4:4))/=0 .AND. (ns==4 .OR. s(5:5)=='_')) THEN out='H2O'//s(5:ns) !--- H2O[_][_] ELSE IF(s(ns-1:ns-1)==phases_sep .AND. INDEX(known_phases,s(ns:ns))/=0) THEN out = s(1:ns-2); RETURN !--- ELSE; DO ip = 1, nphases; ix = INDEX(s, phases_sep//known_phases(ip:ip)//'_'); IF(ix /= 0) EXIT; END DO IF(ip /= nphases+1) out = s(1:ix-1)//s(ix+2:ns) !--- _ END IF END FUNCTION delPhase !============================================================================================================================== CHARACTER(LEN=maxlen) FUNCTION addPhase_s1(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_s1 !============================================================================================================================== FUNCTION addPhase_sm(s,pha) RESULT(out) CHARACTER(LEN=*), INTENT(IN) :: s(:) CHARACTER(LEN=1), INTENT(IN) :: pha CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: k out = [( addPhase_s1(s(k), pha), k=1, SIZE(s) )] END FUNCTION addPhase_sm !============================================================================================================================== CHARACTER(LEN=maxlen) FUNCTION addPhase_i1(s,ipha,phases) RESULT(out) CHARACTER(LEN=*), INTENT(IN) :: s INTEGER, INTENT(IN) :: ipha CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases !------------------------------------------------------------------------------------------------------------------------------ out = s IF(s == '') RETURN !--- Empty string: nothing to do IF(ipha == 0 .OR. ipha > nphases) RETURN !--- Absurd index: no phase to add IF( PRESENT(phases)) out = addPhase_s1(s, phases(ipha:ipha)) IF(.NOT.PRESENT(phases)) out = addPhase_s1(s, known_phases(ipha:ipha)) END FUNCTION addPhase_i1 !============================================================================================================================== FUNCTION addPhase_im(s,ipha,phases) RESULT(out) CHARACTER(LEN=*), INTENT(IN) :: s(:) INTEGER, INTENT(IN) :: ipha CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: k IF( PRESENT(phases)) out = [( addPhase_i1(s(k), ipha, phases), k=1, SIZE(s) )] IF(.NOT.PRESENT(phases)) out = [( addPhase_i1(s(k), ipha, known_phases), k=1, SIZE(s) )] END FUNCTION addPhase_im !============================================================================================================================== !============================================================================================================================== !=== APPEND TRACERS DATABASE "tracs" WITH TRACERS/KEYS "tname"/"keys" ; SAME FOR INTERNAL DATABASE "tracers" ================== !============================================================================================================================== SUBROUTINE addTracer_1(tname, keys, tracs) CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(keys_type), INTENT(IN) :: keys TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tracs(:) TYPE(trac_type), ALLOCATABLE :: tr(:) INTEGER :: nt, ix IF(ALLOCATED(tracs)) THEN nt = SIZE(tracs) ix = strIdx(tracs(:)%name, tname) CALL msg('Modifying existing tracer "'//TRIM(tname)//'"', modname, ix /= 0) CALL msg('Appending with tracer "' //TRIM(tname)//'"', modname, ix == 0) IF(ix == 0) THEN ix = nt+1; ALLOCATE(tr(nt+1)); tr(1:nt) = tracs(1:nt); CALL MOVE_ALLOC(FROM=tr, TO=tracs) END IF ELSE CALL msg('Creating a tracer descriptor with tracer "'//TRIM(tname)//'"', modname) ix = 1; ALLOCATE(tracs(1)) END IF tracs(ix)%name = tname tracs(ix)%keys = keys END SUBROUTINE addTracer_1 !============================================================================================================================== SUBROUTINE addTracer_1def(tname, keys) CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(keys_type), INTENT(IN) :: keys CALL addTracer_1(tname, keys, tracers) END SUBROUTINE addTracer_1def !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION delTracer_1(tname, tracs) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: tname TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: tracs(:) TYPE(trac_type), ALLOCATABLE :: tr(:) INTEGER :: nt, ix lerr = .NOT.ALLOCATED(tracs) IF(fmsg('Can''t remove tracer "'//TRIM(tname)//'" from an empty tracers descriptor', modname, lerr)) RETURN nt = SIZE(tracs) ix = strIdx(tracs(:)%name, tname) CALL msg('Removing tracer "' //TRIM(tname)//'"', modname, ix /= 0) CALL msg('Can''t remove unknown tracer "'//TRIM(tname)//'"', modname, ix == 0) IF(ix /= 0) THEN ALLOCATE(tr(nt-1)); tr(1:ix-1) = tracs(1:ix-1); tr(ix:nt-1) = tracs(ix+1:nt); CALL MOVE_ALLOC(FROM=tr, TO=tracs) END IF END FUNCTION delTracer_1 !============================================================================================================================== LOGICAL FUNCTION delTracer_1def(tname) RESULT(lerr) CHARACTER(LEN=*), INTENT(IN) :: tname lerr = delTracer(tname, tracers) END FUNCTION delTracer_1def !============================================================================================================================== !============================================================================================================================== !=== GET PHASE INDEX IN THE POSSIBLE PHASES LIST OR IN A SPECIFIED LIST ("phases") ============================================ !============================================================================================================================== INTEGER FUNCTION getiPhase(tname, phases) RESULT(iPhase) CHARACTER(LEN=*), INTENT(IN) :: tname CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: phase IF( PRESENT(phases)) phase = getPhase(tname, phases, iPhase) IF(.NOT.PRESENT(phases)) phase = getPhase(tname, known_phases, iPhase) END FUNCTION getiPhase !============================================================================================================================== CHARACTER(LEN=1) FUNCTION getPhase(tname, phases, iPhase) RESULT(phase) CHARACTER(LEN=*), INTENT(IN) :: tname CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: phases INTEGER, OPTIONAL, INTENT(OUT) :: iPhase !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: ip phase = TRIM(strHead(strTail(tname, phases_sep), '_', .TRUE.)) !--- [_] -> [_] -> IF( PRESENT(phases)) ip = INDEX( phases, phase) IF(.NOT.PRESENT(phases)) ip = INDEX(known_phases, phase) IF(ip == 0) phase = 'g' IF(PRESENT(iPhase)) iPhase = ip END FUNCTION getPhase !============================================================================================================================== !============================================================================================================================== !============ CONVERT WATER-DERIVED NAMES FROM FORMER TO CURRENT CONVENTION ; OTHER NAMES ARE LEFT UNTOUCHED ================== !======= NAMES STRUCTURE: H2O[][_][_] ( from "old_phases", from "oldH2OIso") ============ !============================================================================================================================== CHARACTER(LEN=maxlen) FUNCTION old2newH2O_1(oldName, iPhase) RESULT(newName) CHARACTER(LEN=*), INTENT(IN) :: oldName INTEGER, OPTIONAL, INTENT(OUT) :: iPhase !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: tmp(:) INTEGER :: ix, ip, nt LOGICAL :: lerr newName = oldName IF(PRESENT(iPhase)) iPhase = 1 !--- Default: gaseous phase lerr = strParse(oldName, '_', tmp, nt) !--- Parsing: 1 up to 3 elements. ip = strIdx( [('H2O'//old_phases(ix:ix), ix=1, nphases)], tmp(1) ) !--- Phase index IF(ip /= 0 .AND. PRESENT(iPhase)) iPhase = ip !--- Returning phase index IF(ip == 0 .AND. tmp(1) /= 'H2O') RETURN !--- Not an old-style water-related species IF(nt == 1) THEN newName = addPhase('H2O',ip) !=== WATER WITH OR WITHOUT PHASE ELSE ix = strIdx(oldH2OIso, tmp(2)) !--- Index in the known isotopes list IF(ix /= 0) newName = newH2OIso(ix) !--- Move to new isotope name IF(ip /= 0) newName = addPhase(newName, ip) !--- Add phase to isotope name IF(nt == 3) newName = TRIM(newName)//'_'//TRIM(tmp(3)) !=== WATER ISOTOPE OR TAGGING TRACER END IF END FUNCTION old2newH2O_1 !============================================================================================================================== FUNCTION old2newH2O_m(oldName) RESULT(newName) CHARACTER(LEN=*), INTENT(IN) :: oldName(:) CHARACTER(LEN=maxlen) :: newName(SIZE(oldName)) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: i newName = [(old2newH2O_1(oldName(i)), i=1, SIZE(oldName))] END FUNCTION old2newH2O_m !============================================================================================================================== !============================================================================================================================== !============ CONVERT WATER-DERIVED NAMES FROM CURRENT TO FORMER CONVENTION ; OTHER NAMES ARE LEFT UNTOUCHED ================== !==== NAMES STRUCTURE: [][_] ( from "known_phases", = 'H2O' or from "newH2OIso") ===== !============================================================================================================================== CHARACTER(LEN=maxlen) FUNCTION new2oldH2O_1(newName, iPhase) RESULT(oldName) CHARACTER(LEN=*), INTENT(IN) :: newName INTEGER, OPTIONAL, INTENT(OUT) :: iPhase !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: ix, ip CHARACTER(LEN=maxlen) :: var oldName = newName ip = getiPhase(newName) !--- Phase index IF(PRESENT(iPhase)) iPhase = MAX(ip, 1) !--- Return phase index ; default: 1 (gazeous) var = TRIM(strHead(newName, phases_sep, .TRUE.)) !--- Variable without phase and tag ix = strIdx(newH2OIso, var) !--- Index in the known H2O isotopes list IF(ix == 0 .AND. var /= 'H2O') RETURN !--- Neither H2O nor an H2O isotope => finished oldName = 'H2O' IF(ip /= 0) oldName = TRIM(oldName)//old_phases(ip:ip) !--- Add phase if needed IF(ix /= 0) oldName = TRIM(oldName)//'_'//oldH2OIso(ix) !--- H2O isotope name IF(newName /= addPhase(var, ip)) & oldName = TRIM(oldName)//strTail(newName, '_', .TRUE.) !--- Add the tag suffix IF(ip == 0 .AND. ix /= 0) oldName = strTail(oldName, '_') !--- Isotope with no phase: remove 'H2O_' prefix END FUNCTION new2oldH2O_1 !============================================================================================================================== FUNCTION new2oldH2O_m(newName) RESULT(oldName) CHARACTER(LEN=*), INTENT(IN) :: newName(:) CHARACTER(LEN=maxlen) :: oldName(SIZE(newName)) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: i oldName = [(new2oldH2O_1(newName(i)), i=1, SIZE(newName))] END FUNCTION new2oldH2O_m !============================================================================================================================== !============================================================================================================================== !=== GET THE NAME(S) OF THE ANCESTOR(S) OF TRACER(S) "tname" AT GENERATION "igen" IN THE TRACERS DESCRIPTORS LIST "tr" ======= !============================================================================================================================== SUBROUTINE ancestor_1(t, out, tname, igen) TYPE(trac_type), INTENT(IN) :: t(:) CHARACTER(LEN=maxlen), INTENT(OUT) :: out CHARACTER(LEN=*), INTENT(IN) :: tname INTEGER, OPTIONAL, INTENT(IN) :: igen !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: ix CALL idxAncestor_1(t, ix, tname, igen) out = ''; IF(ix /= 0) out = t(ix)%name END SUBROUTINE ancestor_1 !============================================================================================================================== SUBROUTINE ancestor_mt(t, out, tname, igen) TYPE(trac_type), INTENT(IN) :: t(:) CHARACTER(LEN=*), INTENT(IN) :: tname(:) CHARACTER(LEN=maxlen), INTENT(OUT) :: out(SIZE(tname)) INTEGER, OPTIONAL, INTENT(IN) :: igen !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: ix(SIZE(tname)) CALL idxAncestor_mt(t, ix, tname, igen) out(:) = ''; WHERE(ix /= 0) out = t(ix)%name END SUBROUTINE ancestor_mt !============================================================================================================================== SUBROUTINE ancestor_m(t, out, igen) TYPE(trac_type), INTENT(IN) :: t(:) CHARACTER(LEN=maxlen), INTENT(OUT) :: out(SIZE(t)) INTEGER, OPTIONAL, INTENT(IN) :: igen !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: ix(SIZE(t)) CALL idxAncestor_m(t, ix, igen) out(:) = ''; WHERE(ix /= 0) out = t(ix)%name END SUBROUTINE ancestor_m !============================================================================================================================== !============================================================================================================================== !=== GET THE INDEX(ES) OF THE GENERATION "igen" ANCESTOR(S) OF "tname" (t%name IF UNSPECIFIED) IN THE "t" LIST ================ !============================================================================================================================== SUBROUTINE idxAncestor_1(t, idx, tname, igen) TYPE(trac_type), INTENT(IN) :: t(:) INTEGER, INTENT(OUT) :: idx CHARACTER(LEN=*), INTENT(IN) :: tname INTEGER, OPTIONAL, INTENT(IN) :: igen INTEGER :: ig ig = 0; IF(PRESENT(igen)) ig = igen idx = strIdx(t(:)%name, tname) IF(idx == 0) RETURN !--- Tracer not found IF(t(idx)%iGeneration <= ig) RETURN !--- Tracer has a lower generation number than asked generation 'igen" DO WHILE(t(idx)%iGeneration > ig); idx = strIdx(t(:)%name, t(idx)%parent); END DO END SUBROUTINE idxAncestor_1 !------------------------------------------------------------------------------------------------------------------------------ SUBROUTINE idxAncestor_mt(t, idx, tname, igen) TYPE(trac_type), INTENT(IN) :: t(:) CHARACTER(LEN=*), INTENT(IN) :: tname(:) INTEGER, INTENT(OUT) :: idx(SIZE(tname)) INTEGER, OPTIONAL, INTENT(IN) :: igen INTEGER :: ix DO ix = 1, SIZE(tname); CALL idxAncestor_1(t, idx(ix), tname(ix), igen); END DO END SUBROUTINE idxAncestor_mt !------------------------------------------------------------------------------------------------------------------------------ SUBROUTINE idxAncestor_m(t, idx, igen) TYPE(trac_type), INTENT(IN) :: t(:) INTEGER, INTENT(OUT) :: idx(SIZE(t)) INTEGER, OPTIONAL, INTENT(IN) :: igen INTEGER :: ix DO ix = 1, SIZE(t); CALL idxAncestor_1(t, idx(ix), t(ix)%name, igen); END DO END SUBROUTINE idxAncestor_m !============================================================================================================================== END MODULE readTracFiles_mod