Index: LMDZ6/trunk/libf/misc/readTracFiles_mod.f90 =================================================================== --- LMDZ6/trunk/libf/misc/readTracFiles_mod.f90 (revision 4984) +++ LMDZ6/trunk/libf/misc/readTracFiles_mod.f90 (revision 4987) @@ -1,6 +1,7 @@ MODULE readTracFiles_mod - USE strings_mod, ONLY: msg, find, get_in, str2int, dispTable, strHead, strReduce, strFind, strStack, strIdx, & - test, removeComment, cat, fmsg, maxlen, int2str, checkList, strParse, strReplace, strTail, strCount, reduceExpr + 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 @@ -9,12 +10,12 @@ PUBLIC :: maxlen !--- PARAMETER FOR CASUAL STRING LENGTH - PUBLIC :: tracers !--- TRACERS DESCRIPTION DATABASE - PUBLIC :: trac_type, setGeneration, indexUpdate !--- TRACERS DESCRIPTION ASSOCIATED TOOLS + PUBLIC :: trac_type, tracers, setGeneration, indexUpdate !--- TRACERS DESCRIPTION DATABASE + ASSOCIATED TOOLS PUBLIC :: testTracersFiles, readTracersFiles !--- TRACERS FILES READING ROUTINES - PUBLIC :: getKey, fGetKey, fGetKeys, addKey, setDirectKeys !--- TOOLS TO GET/SET KEYS FROM/TO tracers & isotopes - PUBLIC :: getKeysDBase, setKeysDBase !--- TOOLS TO GET/SET THE DATABASE (tracers & isotopes) - - PUBLIC :: addPhase, getiPhase, old_phases, phases_sep, & !--- FUNCTIONS RELATED TO THE PHASES - nphases, delPhase, getPhase, known_phases, phases_names !--- + ASSOCIATED VARIABLES + 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) @@ -24,6 +25,5 @@ !=== FOR ISOTOPES: GENERAL - PUBLIC :: isot_type, readIsotopesFile, isoSelect !--- ISOTOPES DESCRIPTION TYPE + READING ROUTINE - PUBLIC :: ixIso, nbIso !--- INDEX OF SELECTED ISOTOPES CLASS + NUMBER OF CLASSES + PUBLIC :: isot_type, readIsotopesFile, isoSelect, ixIso, nbIso!--- ISOTOPES READING ROUTINE + SELECTION + CLASS IDX & NUMBER !=== FOR ISOTOPES: H2O FAMILY ONLY @@ -41,54 +41,53 @@ 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 + 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 - 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) - TYPE(keys_type) :: keys !--- = pairs vector - 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 + 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) - LOGICAL :: check=.FALSE. !--- Triggering of the checking routines - TYPE(keys_type), ALLOCATABLE :: keys(:) !--- Isotopes keys/values pairs list (length: niso) - 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 :: nzone = 0 !--- Number of geographic tagging zones - INTEGER :: ntiso = 0 !--- Number of isotopes, including tagging tracers - INTEGER :: nphas = 0 !--- Number phases - INTEGER, ALLOCATABLE :: iqIsoPha(:,:) !--- Idx in "tracers(1:nqtot)" = f(name(1:ntiso)),phas) - !--- "iqIsoPha" former name: "iqiso" - INTEGER, ALLOCATABLE :: iqWIsoPha(:,:) !--- Idx in "tracers(1:nqtot)" = f(name(1:ntiso)),phas) - !--- "iqIsoPha" former name: "iqiso" - INTEGER, ALLOCATABLE :: itZonIso(:,:) !--- Idx in "trac(1:ntiso)" = f(zone, name(1:niso)) - !--- "itZonIso" former name: "index_trac" - END TYPE isot_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 + CHARACTER(LEN=maxlen) :: name !--- Section name TYPE(trac_type), ALLOCATABLE :: trac(:) !--- Tracers descriptors END TYPE dataBase_type @@ -100,4 +99,9 @@ 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 @@ -108,5 +112,6 @@ 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 addKey; MODULE PROCEDURE addKey_1; END INTERFACE addKey!, addKey_m, addKey_mm; END INTERFACE addKey + 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 !------------------------------------------------------------------------------------------------------------------------------ @@ -117,12 +122,10 @@ !--- 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 + 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 ','blosno '] - CHARACTER(LEN=1), SAVE :: phases_sep = '_' !--- Phase separator - LOGICAL, SAVE :: tracs_merge = .TRUE. !--- Merge/stack tracers lists - LOGICAL, SAVE :: lSortByGen = .TRUE. !--- Sort by growing generation + = ['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 @@ -131,5 +134,5 @@ CHARACTER(LEN=maxlen), SAVE :: newH2OIso(5) = ['H216O', 'HDO ', 'H218O', 'H217O', 'HTO '] - !--- CORRESPONDANCE BETWEEN OLD AND NEW HNO3 RELATED SPECIES NAMES + !--- 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'] @@ -141,5 +144,5 @@ !=== 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 !--- Index of the selected isotopes family and H2O family + 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 @@ -151,6 +154,10 @@ 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) + 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" @@ -231,5 +238,5 @@ IF(ix /= 0 .AND. lRep) tname = newHNO3(ix) !--- Exception for HNO3 (REPROBUS ONLY) tracers(it)%name = tname !--- Set %name - CALL addKey_1('name', tname, k) !--- Set the name of the tracer + CALL addKey_s11('name', tname, k) !--- Set the name of the tracer tracers(it)%keys%name = tname !--- Copy tracers names in keys components @@ -238,5 +245,5 @@ IF(ANY([(addPhase('H2O', ip), ip = 1, nphases)] == tname)) cname = 'lmdz' tracers(it)%component = cname !--- Set %component - CALL addKey_1('component', cname, k) !--- Set the name of the model component + CALL addKey_s11('component', cname, k) !--- Set the name of the model component !=== NAME OF THE PARENT @@ -248,11 +255,11 @@ END IF tracers(it)%parent = pname !--- Set %parent - CALL addKey_1('parent', pname, k) + 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_1('phase', known_phases(ip:ip), k) !--- Set the phase of the tracer (default: "g"azeous) - CALL addKey_1('hadv', s(1), k) !--- Set the horizontal advection schemes number - CALL addKey_1('vadv', s(2), k) !--- Set the vertical advection schemes number + 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) @@ -260,5 +267,5 @@ WHERE(tracers%iGeneration == 2) tracers(:)%type = 'tag' !--- Set %type: 'tracer' or 'tag' DO it=1,ntrac - CALL addKey_1('type', tracers(it)%type, tracers(it)%keys) !--- Set the type of tracer + 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 @@ -276,5 +283,5 @@ IF(nsec == 1) THEN; tracers = dBase(1)%trac - ELSE IF(tracs_merge) THEN + ELSE IF(lTracsMerge) THEN CALL msg('The multiple required sections will be MERGED.', modname) IF(test(mergeTracers(dBase, tracers), lerr)) RETURN @@ -435,8 +442,8 @@ ll = strParse(str,' ', s, n, v) !--- Parse = pairs tt = dBase(ndb)%trac(:) - tmp%name = s(1); tmp%keys = keys_type(s(1), s(2:n), v(2:n)) !--- Set %name and %keys + 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) -! dBase(ndb)%trac = [dBase(ndb)%trac(:), tra(name=s(1), keys=keys_type(s(1), s(2:n), v(2:n)))] END IF END DO @@ -465,5 +472,5 @@ 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_1(ky%key(k), ky%val(k), t(it)%keys, .FALSE.); END DO + 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" @@ -528,6 +535,6 @@ tr(it)%type = fgetKey(it, 'type' , tr(:)%keys, 'tracer') tr(it)%component = sname -! CALL addKey_m('component', sname, tr(:)%keys) - DO iq=1,SIZE(tr); CALL addKey_1('component', sname, tr(iq)%keys); END DO +! 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 @@ -558,8 +565,8 @@ ttr(iq)%keys%val = tr(it)%keys%val ttr(iq)%keys%name = ta(itr) - ttr(iq)%name = TRIM(ta(itr)); CALL addKey_1('name', ta(itr), ttr(iq)%keys) - ttr(iq)%parent = TRIM(pa(ipr)); CALL addKey_1('parent', pa(ipr), ttr(iq)%keys) - ttr(iq)%type = tr(it)%type; CALL addKey_1('type', tr(it)%type, ttr(iq)%keys) - ttr(iq)%component = tr(it)%component; CALL addKey_1('component', tr(it)%component, ttr(iq)%keys) + 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 @@ -597,6 +604,6 @@ ig = ig + 1 END DO - tr(iq)%gen0Name = tr(jq)%name; CALL addKey_1('gen0Name', tr(iq)%gen0Name, tr(iq)%keys) - tr(iq)%iGeneration = ig; CALL addKey_1('iGeneration', TRIM(int2str(ig)), tr(iq)%keys) + 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 @@ -723,11 +730,11 @@ ttr(it)%keys%name = TRIM(nam) !--- Name inside the keys decriptor ttr(it)%phase = p !--- Single phase entry - CALL addKey_1('name', nam, ttr(it)%keys) - CALL addKey_1('phase', p, ttr(it)%keys) + 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_1('parent', ttr(it)%parent, ttr(it)%keys) - CALL addKey_1('gen0Name', ttr(it)%gen0Name, ttr(it)%keys) + 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 @@ -1001,5 +1008,5 @@ INTEGER :: iq, ig, igen, ngen, ix(SIZE(tr)) tr(:)%iqParent = strIdx( tr(:)%name, tr(:)%parent ) !--- Parent index - DO iq = 1, SIZE(tr); CALL addKey_1('iqParent', int2str(tr(iq)%iqParent), tr(iq)%keys); END DO + 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) @@ -1013,9 +1020,9 @@ IF(igen == ig+1) THEN tr(iq)%nqChildren = tr(iq)%nqDescen - CALL addKey_1('nqChildren', int2str(tr(iq)%nqChildren), tr(iq)%keys) + CALL addKey_s11('nqChildren', int2str(tr(iq)%nqChildren), tr(iq)%keys) END IF END DO - CALL addKey_1('iqDescen', strStack(int2str(tr(iq)%iqDescen)), tr(iq)%keys) - CALL addKey_1('nqDescen', int2str(tr(iq)%nqDescen) , tr(iq)%keys) + 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 @@ -1303,6 +1310,6 @@ !=== ADD THE = PAIR TO THE "ky[(:)]" KEY[S] DESCRIPTOR[S] OR THE = PAIRS TO THE "ky(:)" KEYS DESCRIPTORS !============================================================================================================================== -SUBROUTINE addKey_1(key, val, ky, lOverWrite) - CHARACTER(LEN=*), INTENT(IN) :: key, val +SUBROUTINE addKey_s11(key, sval, ky, lOverWrite) + CHARACTER(LEN=*), INTENT(IN) :: key, sval TYPE(keys_type), INTENT(INOUT) :: ky LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite @@ -1314,5 +1321,5 @@ IF(.NOT.ALLOCATED(ky%key)) THEN ALLOCATE(ky%key(1)); ky%key(1)=key - ALLOCATE(ky%val(1)); ky%val(1)=val + ALLOCATE(ky%val(1)); ky%val(1)=sval RETURN END IF @@ -1320,13 +1327,41 @@ 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) = val; ky%val = v + 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) = val + ky%key(iky) = key; ky%val(iky) = sval END IF -END SUBROUTINE addKey_1 -!============================================================================================================================== -SUBROUTINE addKey_m(key, val, ky, lOverWrite) - CHARACTER(LEN=*), INTENT(IN) :: key, val +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 @@ -1334,16 +1369,83 @@ INTEGER :: itr DO itr = 1, SIZE(ky) - CALL addKey_1(key, val, ky(itr), lOverWrite) - END DO -END SUBROUTINE addKey_m -!============================================================================================================================== -SUBROUTINE addKey_mm(key, val, ky, lOverWrite) - CHARACTER(LEN=*), INTENT(IN) :: key, val(:) + 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_1(key, val(itr), ky(itr), lOverWrite); END DO -END SUBROUTINE addKey_mm + 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 !============================================================================================================================== @@ -1362,5 +1464,5 @@ DO ik = 1, SIZE(t(jd)%keys%key) CALL get_in(t(jd)%keys%key(ik), val, '*none*') - IF(val /= '*none*') CALL addKey_1(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.) + IF(val /= '*none*') CALL addKey_s11(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.) END DO END SUBROUTINE addKeysFromDef @@ -1821,4 +1923,61 @@ !============================================================================================================================== +!=== 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") ============================================ !============================================================================================================================== Index: LMDZ6/trunk/libf/misc/strings_mod.F90 =================================================================== --- LMDZ6/trunk/libf/misc/strings_mod.F90 (revision 4984) +++ LMDZ6/trunk/libf/misc/strings_mod.F90 (revision 4987) @@ -1341,10 +1341,17 @@ !=== Convert a string into a logical/integer integer or an integer/real into a string ========================================= !============================================================================================================================== -ELEMENTAL LOGICAL FUNCTION str2bool(str) RESULT(out) +ELEMENTAL INTEGER FUNCTION str2bool(str) RESULT(out) !--- Result: 0/1 for .FALSE./.TRUE., -1 if not a valid boolean + IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str INTEGER :: ierr - READ(str,*,IOSTAT=ierr) out - IF(ierr==0) RETURN - out = ANY(['t ','true ','.true.','y ','yes ']==strLower(str)) + LOGICAL :: lout + READ(str,*,IOSTAT=ierr) lout + out = -HUGE(1) + IF(ierr /= 0) THEN + IF(ANY(['.false.', 'false ', 'no ', 'f ', 'n '] == strLower(str))) out = 0 + IF(ANY(['.true. ', 'true ', 'yes ', 't ', 'y '] == strLower(str))) out = 1 + ELSE + out = 0; IF(lout) out = 1 + END IF END FUNCTION str2bool !==============================================================================================================================