Changeset 4987 for LMDZ6/trunk
- Timestamp:
- Jun 17, 2024, 8:46:00 PM (13 days ago)
- Location:
- LMDZ6/trunk/libf/misc
- Files:
-
- 2 edited
-
readTracFiles_mod.f90 (modified) (29 diffs)
-
strings_mod.F90 (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/trunk/libf/misc/readTracFiles_mod.f90
r4984 r4987 1 1 MODULE readTracFiles_mod 2 2 3 USE strings_mod, ONLY: msg, find, get_in, str2int, dispTable, strHead, strReduce, strFind, strStack, strIdx, & 4 test, removeComment, cat, fmsg, maxlen, int2str, checkList, strParse, strReplace, strTail, strCount, reduceExpr 3 USE strings_mod, ONLY: msg, find, get_in, dispTable, strHead, strReduce, strFind, strStack, strIdx, & 4 test, removeComment, cat, fmsg, maxlen, checkList, strParse, strReplace, strTail, strCount, reduceExpr, & 5 int2str, str2int, real2str, str2real, bool2str, str2bool 5 6 6 7 IMPLICIT NONE … … 9 10 10 11 PUBLIC :: maxlen !--- PARAMETER FOR CASUAL STRING LENGTH 11 PUBLIC :: tracers !--- TRACERS DESCRIPTION DATABASE 12 PUBLIC :: trac_type, setGeneration, indexUpdate !--- TRACERS DESCRIPTION ASSOCIATED TOOLS 12 PUBLIC :: trac_type, tracers, setGeneration, indexUpdate !--- TRACERS DESCRIPTION DATABASE + ASSOCIATED TOOLS 13 13 PUBLIC :: testTracersFiles, readTracersFiles !--- TRACERS FILES READING ROUTINES 14 PUBLIC :: getKey, fGetKey, fGetKeys, addKey, setDirectKeys !--- TOOLS TO GET/SET KEYS FROM/TO tracers & isotopes 15 PUBLIC :: getKeysDBase, setKeysDBase !--- TOOLS TO GET/SET THE DATABASE (tracers & isotopes) 16 17 PUBLIC :: addPhase, getiPhase, old_phases, phases_sep, & !--- FUNCTIONS RELATED TO THE PHASES 18 nphases, delPhase, getPhase, known_phases, phases_names !--- + ASSOCIATED VARIABLES 14 PUBLIC :: getKeysDBase, setKeysDBase !--- TOOLS TO GET/SET THE DATABASE (tracers & isotopes) 15 PUBLIC :: addTracer, delTracer !--- ADD/REMOVE A TRACER FROM 16 PUBLIC :: addKey, delKey, getKey, keys_type !--- TOOLS TO SET/DEL/GET KEYS FROM/TO tracers & isotopes 17 PUBLIC :: addPhase, delPhase, getPhase, getiPhase, & !--- FUNCTIONS RELATED TO THE PHASES 18 nphases, old_phases, phases_sep, known_phases, phases_names !--- + ASSOCIATED VARIABLES 19 PUBLIC :: fGetKey, fGetKeys, setDirectKeys !--- TOOLS TO GET/SET KEYS FROM/TO tracers & isotopes TO BE REMOVED 19 20 20 21 PUBLIC :: oldH2OIso, newH2OIso, old2newH2O, new2oldH2O !--- H2O ISOTOPES BACKWARD COMPATIBILITY (OLD traceur.def) … … 24 25 25 26 !=== FOR ISOTOPES: GENERAL 26 PUBLIC :: isot_type, readIsotopesFile, isoSelect !--- ISOTOPES DESCRIPTION TYPE + READING ROUTINE 27 PUBLIC :: ixIso, nbIso !--- INDEX OF SELECTED ISOTOPES CLASS + NUMBER OF CLASSES 27 PUBLIC :: isot_type, readIsotopesFile, isoSelect, ixIso, nbIso!--- ISOTOPES READING ROUTINE + SELECTION + CLASS IDX & NUMBER 28 28 29 29 !=== FOR ISOTOPES: H2O FAMILY ONLY … … 41 41 PUBLIC :: maxTableWidth 42 42 !------------------------------------------------------------------------------------------------------------------------------ 43 TYPE :: keys_type !=== TYPE FOR A SET OF KEYS ASSOCIATED TO AN ELEMENT44 CHARACTER(LEN=maxlen) :: name !--- Tracer name45 CHARACTER(LEN=maxlen), ALLOCATABLE :: key(:) !--- Keys string list46 CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:) !--- Corresponding values string list43 TYPE :: keys_type !=== TYPE FOR A SET OF KEYS ASSOCIATED TO AN ELEMENT 44 CHARACTER(LEN=maxlen) :: name !--- Tracer name 45 CHARACTER(LEN=maxlen), ALLOCATABLE :: key(:) !--- Keys string list 46 CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:) !--- Corresponding values string list 47 47 END TYPE keys_type 48 48 !------------------------------------------------------------------------------------------------------------------------------ 49 TYPE :: trac_type !=== TYPE FOR A SINGLE TRACER NAMED "name"50 CHARACTER(LEN=maxlen) :: name = '' !--- Name of the tracer51 CHARACTER(LEN=maxlen) :: gen0Name = '' !--- First generation ancestor name52 CHARACTER(LEN=maxlen) :: parent = '' !--- Parentname53 CHARACTER(LEN=maxlen) :: longName = '' !--- Long name (with advection scheme suffix)54 CHARACTER(LEN=maxlen) :: type = 'tracer' !--- Type (so far: 'tracer' / 'tag')55 CHARACTER(LEN=maxlen) :: phase = 'g' !--- Phase ('g'as / 'l'iquid / 's'olid)56 CHARACTER(LEN=maxlen) :: component = '' !--- Coma-separated list of components (Ex: lmdz,inca)57 INTEGER :: iGeneration = -1 !--- Generation number (>=0)58 INTEGER :: i qParent = 0 !--- Parent index59 INTEGER , ALLOCATABLE :: iqDescen(:) !--- Descendants index (in growing generation order)60 INTEGER :: nqDescen = 0 !--- Number of descendants (all generations)61 INTEGER :: nq Children = 0 !--- Number of children (first generation)62 TYPE(keys_type) :: keys !--- <key>=<val> pairs vector63 INTEGER :: iadv = 10 !--- Advection scheme used64 LOGICAL :: isAdvected = .FALSE. !--- "true" tracers: iadv > 0. COUNT(isAdvected )=nqtrue65 LOGICAL :: isInPhysics = .TRUE. !--- "true" tracers: in tr_seri. COUNT(isInPhysics)=nqtottr66 INTEGER :: iso_iGroup = 0 !--- Isotopes group index in isotopes(:)67 INTEGER :: iso_iName = 0 !--- Isotope name index in isotopes(iso_iGroup)%trac(:)68 INTEGER :: iso_iZone = 0 !--- Isotope zone index in isotopes(iso_iGroup)%zone(:)69 INTEGER :: iso_iPhase = 0 !--- Isotope phase index in isotopes(iso_iGroup)%phase49 TYPE :: trac_type !=== TYPE FOR A SINGLE TRACER NAMED "name" 50 CHARACTER(LEN=maxlen) :: name = '' !--- Name of the tracer 51 TYPE(keys_type) :: keys !--- <key>=<val> pairs vector 52 CHARACTER(LEN=maxlen) :: gen0Name = '' !--- First generation ancestor name 53 CHARACTER(LEN=maxlen) :: parent = '' !--- Parent name 54 CHARACTER(LEN=maxlen) :: longName = '' !--- Long name (with advection scheme suffix) 55 CHARACTER(LEN=maxlen) :: type = 'tracer' !--- Type (so far: 'tracer' / 'tag') 56 CHARACTER(LEN=maxlen) :: phase = 'g' !--- Phase ('g'as / 'l'iquid / 's'olid) 57 CHARACTER(LEN=maxlen) :: component = '' !--- Coma-separated list of components (Ex: lmdz,inca) 58 INTEGER :: iGeneration = -1 !--- Generation number (>=0) 59 INTEGER :: iqParent = 0 !--- Parent index 60 INTEGER, ALLOCATABLE :: iqDescen(:) !--- Descendants index (in growing generation order) 61 INTEGER :: nqDescen = 0 !--- Number of descendants (all generations) 62 INTEGER :: nqChildren = 0 !--- Number of children (first generation) 63 INTEGER :: iadv = 10 !--- Advection scheme used 64 LOGICAL :: isAdvected = .FALSE. !--- "true" tracers: iadv > 0. COUNT(isAdvected )=nqtrue 65 LOGICAL :: isInPhysics = .TRUE. !--- "true" tracers: in tr_seri. COUNT(isInPhysics)=nqtottr 66 INTEGER :: iso_iGroup = 0 !--- Isotopes group index in isotopes(:) 67 INTEGER :: iso_iName = 0 !--- Isotope name index in isotopes(iso_iGroup)%trac(:) 68 INTEGER :: iso_iZone = 0 !--- Isotope zone index in isotopes(iso_iGroup)%zone(:) 69 INTEGER :: iso_iPhase = 0 !--- Isotope phase index in isotopes(iso_iGroup)%phase 70 70 END TYPE trac_type 71 71 !------------------------------------------------------------------------------------------------------------------------------ 72 TYPE :: isot_type !=== TYPE FOR AN ISOTOPES FAMILY DESCENDING ON TRACER "parent" 73 CHARACTER(LEN=maxlen) :: parent !--- Isotopes family name (parent tracer name ; ex: H2O) 74 LOGICAL :: check=.FALSE. !--- Triggering of the checking routines 75 TYPE(keys_type), ALLOCATABLE :: keys(:) !--- Isotopes keys/values pairs list (length: niso) 76 CHARACTER(LEN=maxlen), ALLOCATABLE :: trac(:) !--- Isotopes + tagging tracers list (length: ntiso) 77 CHARACTER(LEN=maxlen), ALLOCATABLE :: zone(:) !--- Geographic tagging zones names list (length: nzone) 78 CHARACTER(LEN=maxlen) :: phase = 'g' !--- Phases list: [g][l][s] (length: nphas) 79 INTEGER :: niso = 0 !--- Number of isotopes, excluding tagging tracers 80 INTEGER :: nzone = 0 !--- Number of geographic tagging zones 81 INTEGER :: ntiso = 0 !--- Number of isotopes, including tagging tracers 82 INTEGER :: nphas = 0 !--- Number phases 83 INTEGER, ALLOCATABLE :: iqIsoPha(:,:) !--- Idx in "tracers(1:nqtot)" = f(name(1:ntiso)),phas) 84 !--- "iqIsoPha" former name: "iqiso" 85 INTEGER, ALLOCATABLE :: iqWIsoPha(:,:) !--- Idx in "tracers(1:nqtot)" = f(name(1:ntiso)),phas) 86 !--- "iqIsoPha" former name: "iqiso" 87 INTEGER, ALLOCATABLE :: itZonIso(:,:) !--- Idx in "trac(1:ntiso)" = f(zone, name(1:niso)) 88 !--- "itZonIso" former name: "index_trac" 89 END TYPE isot_type 72 TYPE :: isot_type !=== TYPE FOR AN ISOTOPES FAMILY DESCENDING ON TRACER "parent" 73 CHARACTER(LEN=maxlen) :: parent !--- Isotopes family name (parent tracer name ; ex: H2O) 74 TYPE(keys_type), ALLOCATABLE :: keys(:) !--- Isotopes keys/values pairs list (length: niso) 75 LOGICAL :: check=.FALSE. !--- Flag for checking routines triggering 76 CHARACTER(LEN=maxlen), ALLOCATABLE :: trac(:) !--- Isotopes + tagging tracers list (length: ntiso) 77 CHARACTER(LEN=maxlen), ALLOCATABLE :: zone(:) !--- Geographic tagging zones names list (length: nzone) 78 CHARACTER(LEN=maxlen) :: phase = 'g' !--- Phases list: [g][l][s] (length: nphas) 79 INTEGER :: niso = 0 !--- Number of isotopes, excluding tagging tracers 80 INTEGER :: ntiso = 0 !--- Number of isotopes, including tagging tracers 81 INTEGER :: nzone = 0 !--- Number of geographic tagging zones 82 INTEGER :: nphas = 0 !--- Number of phases 83 INTEGER, ALLOCATABLE :: iqIsoPha(:,:) !--- Idx in "tracers(1:nqtot)" = f(name(1:ntiso)),phas) 84 !--- (former name: "iqiso" 85 INTEGER, ALLOCATABLE :: iqWIsoPha(:,:) !--- Idx in "tracers(1:nqtot)" = f(name(1:ntiso)),phas) 86 !--- (former name: "?????") 87 INTEGER, ALLOCATABLE :: itZonIso(:,:) !--- Idx in "trac(1:ntiso)" = f(zone, name(1:niso)) 88 END TYPE isot_type !--- (former name: "index_trac") 90 89 !------------------------------------------------------------------------------------------------------------------------------ 91 90 TYPE :: dataBase_type !=== TYPE FOR TRACERS SECTION 92 CHARACTER(LEN=maxlen) :: name!--- Section name91 CHARACTER(LEN=maxlen) :: name !--- Section name 93 92 TYPE(trac_type), ALLOCATABLE :: trac(:) !--- Tracers descriptors 94 93 END TYPE dataBase_type … … 100 99 getKeyByName_l1, getKeyByName_l1m, getKeyByName_lm, getKey_lm 101 100 END INTERFACE getKey 101 !------------------------------------------------------------------------------------------------------------------------------ 102 INTERFACE addKey 103 MODULE PROCEDURE addKey_s11, addKey_s1m, addKey_smm, addKey_i11, addKey_i1m, addKey_imm, & 104 addKey_r11, addKey_r1m, addKey_rmm, addKey_l11, addKey_l1m, addKey_lmm 105 END INTERFACE addKey 102 106 !------------------------------------------------------------------------------------------------------------------------------ 103 107 INTERFACE isoSelect; MODULE PROCEDURE isoSelectByIndex, isoSelectByName; END INTERFACE isoSelect … … 108 112 INTERFACE idxAncestor; MODULE PROCEDURE idxAncestor_1, idxAncestor_m, idxAncestor_mt; END INTERFACE idxAncestor 109 113 INTERFACE ancestor; MODULE PROCEDURE ancestor_1, ancestor_m, ancestor_mt; END INTERFACE ancestor 110 INTERFACE addKey; MODULE PROCEDURE addKey_1; END INTERFACE addKey!, addKey_m, addKey_mm; END INTERFACE addKey 114 INTERFACE addTracer; MODULE PROCEDURE addTracer_1, addTracer_1def; END INTERFACE addTracer 115 INTERFACE delTracer; MODULE PROCEDURE delTracer_1, delTracer_1def; END INTERFACE delTracer 111 116 INTERFACE addPhase; MODULE PROCEDURE addPhase_s1, addPhase_sm, addPhase_i1, addPhase_im; END INTERFACE addPhase 112 117 !------------------------------------------------------------------------------------------------------------------------------ … … 117 122 !--- SOME PARAMETERS THAT ARE NOT LIKELY TO CHANGE OFTEN 118 123 CHARACTER(LEN=maxlen), SAVE :: tran0 = 'air' !--- Default transporting fluid 119 CHARACTER(LEN=maxlen), PARAMETER :: old_phases = 'vlirb' 120 CHARACTER(LEN=maxlen), PARAMETER :: known_phases = 'glsrb' 124 CHARACTER(LEN=maxlen), PARAMETER :: old_phases = 'vlirb' !--- Old phases for water (no separator) 125 CHARACTER(LEN=maxlen), PARAMETER :: known_phases = 'glsrb' !--- Known phases initials 121 126 INTEGER, PARAMETER :: nphases = LEN_TRIM(known_phases) !--- Number of phases 122 127 CHARACTER(LEN=maxlen), SAVE :: phases_names(nphases) & !--- Known phases names 123 = ['gaseous', 'liquid ', 'solid ', 'cloud ','blosno '] 124 CHARACTER(LEN=1), SAVE :: phases_sep = '_' !--- Phase separator 125 LOGICAL, SAVE :: tracs_merge = .TRUE. !--- Merge/stack tracers lists 126 LOGICAL, SAVE :: lSortByGen = .TRUE. !--- Sort by growing generation 128 = ['gaseous ', 'liquid ', 'solid ', 'cloud ','blownSnow'] 129 CHARACTER(LEN=1), SAVE :: phases_sep = '_' !--- Phase separator 127 130 CHARACTER(LEN=maxlen), SAVE :: isoFile = 'isotopes_params.def'!--- Name of the isotopes parameters file 128 131 … … 131 134 CHARACTER(LEN=maxlen), SAVE :: newH2OIso(5) = ['H216O', 'HDO ', 'H218O', 'H217O', 'HTO '] 132 135 133 !--- CORRESPONDANCE BETWEEN OLD AND NEW HNO3 RELATED SPECIES NAMES 136 !--- CORRESPONDANCE BETWEEN OLD AND NEW HNO3 RELATED SPECIES NAMES (FOR REPROBUS) 134 137 CHARACTER(LEN=maxlen), SAVE :: oldHNO3(2) = ['HNO3_g ', 'HNO3 '] 135 138 CHARACTER(LEN=maxlen), SAVE :: newHNO3(2) = ['HNO3 ', 'HNO3tot'] … … 141 144 !=== ALIASES OF VARIABLES FROM SELECTED ISOTOPES FAMILY EMBEDDED IN "isotope" (isotopes(ixIso)) 142 145 TYPE(isot_type), SAVE, POINTER :: isotope !--- CURRENTLY SELECTED ISOTOPES FAMILY DESCRIPTOR 143 INTEGER, SAVE :: ixIso, iH2O 146 INTEGER, SAVE :: ixIso, iH2O=0 !--- Index of the selected isotopes family and H2O family 144 147 INTEGER, SAVE :: nbIso !--- Number of isotopes classes 145 148 LOGICAL, SAVE :: isoCheck !--- Flag to trigger the checking routines … … 151 154 nphas, ntiso !--- NUMBER OF PHASES AND ISOTOPES + ISOTOPIC TAGGING TRACERS 152 155 INTEGER, SAVE, POINTER ::itZonIso(:,:), & !--- INDEX IN "isoTrac" AS f(tagging zone idx, isotope idx) 153 iqIsoPha(:,:), & 156 iqIsoPha(:,:), & !--- INDEX IN "qx" AS f(isotopic tracer idx, phase idx) 154 157 iqWIsoPha(:,:) !--- INDEX IN "qx" AS f(isotopic tracer idx, phase idx) 158 159 !=== PARAMETERS FOR DEFAULT BEHAVIOUR 160 LOGICAL, PARAMETER :: lTracsMerge = .FALSE. !--- Merge/stack tracers lists 161 LOGICAL, PARAMETER :: lSortByGen = .TRUE. !--- Sort by growing generation 155 162 156 163 INTEGER, PARAMETER :: maxTableWidth = 192 !--- Maximum width of a table displayed with "dispTable" … … 231 238 IF(ix /= 0 .AND. lRep) tname = newHNO3(ix) !--- Exception for HNO3 (REPROBUS ONLY) 232 239 tracers(it)%name = tname !--- Set %name 233 CALL addKey_ 1('name', tname, k)!--- Set the name of the tracer240 CALL addKey_s11('name', tname, k) !--- Set the name of the tracer 234 241 tracers(it)%keys%name = tname !--- Copy tracers names in keys components 235 242 … … 238 245 IF(ANY([(addPhase('H2O', ip), ip = 1, nphases)] == tname)) cname = 'lmdz' 239 246 tracers(it)%component = cname !--- Set %component 240 CALL addKey_ 1('component', cname, k)!--- Set the name of the model component247 CALL addKey_s11('component', cname, k) !--- Set the name of the model component 241 248 242 249 !=== NAME OF THE PARENT … … 248 255 END IF 249 256 tracers(it)%parent = pname !--- Set %parent 250 CALL addKey_ 1('parent', pname, k)257 CALL addKey_s11('parent', pname, k) 251 258 252 259 !=== PHASE AND ADVECTION SCHEMES NUMBERS 253 260 tracers(it)%phase = known_phases(ip:ip) !--- Set %phase: tracer phase (default: "g"azeous) 254 CALL addKey_ 1('phase', known_phases(ip:ip), k)!--- Set the phase of the tracer (default: "g"azeous)255 CALL addKey_ 1('hadv', s(1), k)!--- Set the horizontal advection schemes number256 CALL addKey_ 1('vadv', s(2), k)!--- Set the vertical advection schemes number261 CALL addKey_s11('phase', known_phases(ip:ip), k) !--- Set the phase of the tracer (default: "g"azeous) 262 CALL addKey_s11('hadv', s(1), k) !--- Set the horizontal advection schemes number 263 CALL addKey_s11('vadv', s(2), k) !--- Set the vertical advection schemes number 257 264 END DO 258 265 CLOSE(90) … … 260 267 WHERE(tracers%iGeneration == 2) tracers(:)%type = 'tag' !--- Set %type: 'tracer' or 'tag' 261 268 DO it=1,ntrac 262 CALL addKey_ 1('type', tracers(it)%type, tracers(it)%keys)!--- Set the type of tracer269 CALL addKey_s11('type', tracers(it)%type, tracers(it)%keys) !--- Set the type of tracer 263 270 END DO 264 271 IF(test(checkTracers(tracers, fname, fname), lerr)) RETURN !--- Detect orphans and check phases … … 276 283 IF(nsec == 1) THEN; 277 284 tracers = dBase(1)%trac 278 ELSE IF( tracs_merge) THEN285 ELSE IF(lTracsMerge) THEN 279 286 CALL msg('The multiple required sections will be MERGED.', modname) 280 287 IF(test(mergeTracers(dBase, tracers), lerr)) RETURN … … 435 442 ll = strParse(str,' ', s, n, v) !--- Parse <key>=<val> pairs 436 443 tt = dBase(ndb)%trac(:) 437 tmp%name = s(1); tmp%keys = keys_type(s(1), s(2:n), v(2:n)) !--- Set %name and %keys 444 v(1) = s(1); s(1) = 'name' !--- Convert "name" into a regular key 445 tmp%name = v(1); tmp%keys = keys_type(v(1), s(:), v(:)) !--- Set %name and %keys 438 446 dBase(ndb)%trac = [tt(:), tmp] 439 447 DEALLOCATE(tt) 440 ! dBase(ndb)%trac = [dBase(ndb)%trac(:), tra(name=s(1), keys=keys_type(s(1), s(2:n), v(2:n)))]441 448 END IF 442 449 END DO … … 465 472 DO k = 1, SIZE(ky%key) !--- Loop on the keys of the tracer named "defName" 466 473 ! CALL addKey_m(ky%key(k), ky%val(k), t(:)%keys, .FALSE.) !--- Add key to all the tracers (no overwriting) 467 DO it = 1, SIZE(t); CALL addKey_ 1(ky%key(k), ky%val(k), t(it)%keys, .FALSE.); END DO474 DO it = 1, SIZE(t); CALL addKey_s11(ky%key(k), ky%val(k), t(it)%keys, .FALSE.); END DO 468 475 END DO 469 476 tt = [t(1:jd-1),t(jd+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t) !--- Remove the virtual tracer named "defName" … … 528 535 tr(it)%type = fgetKey(it, 'type' , tr(:)%keys, 'tracer') 529 536 tr(it)%component = sname 530 ! CALL addKey_ m('component', sname, tr(:)%keys)531 DO iq=1,SIZE(tr); CALL addKey_ 1('component', sname, tr(iq)%keys); END DO537 ! CALL addKey_s1m('component', sname, tr(:)%keys) 538 DO iq=1,SIZE(tr); CALL addKey_s11('component', sname, tr(iq)%keys); END DO 532 539 533 540 !--- Determine the number of tracers and parents ; coherence checking … … 558 565 ttr(iq)%keys%val = tr(it)%keys%val 559 566 ttr(iq)%keys%name = ta(itr) 560 ttr(iq)%name = TRIM(ta(itr)); CALL addKey_ 1('name', ta(itr), ttr(iq)%keys)561 ttr(iq)%parent = TRIM(pa(ipr)); CALL addKey_ 1('parent', pa(ipr), ttr(iq)%keys)562 ttr(iq)%type = tr(it)%type; CALL addKey_ 1('type', tr(it)%type, ttr(iq)%keys)563 ttr(iq)%component = tr(it)%component; CALL addKey_ 1('component', tr(it)%component, ttr(iq)%keys)567 ttr(iq)%name = TRIM(ta(itr)); CALL addKey_s11('name', ta(itr), ttr(iq)%keys) 568 ttr(iq)%parent = TRIM(pa(ipr)); CALL addKey_s11('parent', pa(ipr), ttr(iq)%keys) 569 ttr(iq)%type = tr(it)%type; CALL addKey_s11('type', tr(it)%type, ttr(iq)%keys) 570 ttr(iq)%component = tr(it)%component; CALL addKey_s11('component', tr(it)%component, ttr(iq)%keys) 564 571 iq = iq+1 565 572 END DO … … 597 604 ig = ig + 1 598 605 END DO 599 tr(iq)%gen0Name = tr(jq)%name; CALL addKey_ 1('gen0Name', tr(iq)%gen0Name, tr(iq)%keys)600 tr(iq)%iGeneration = ig; CALL addKey_ 1('iGeneration', TRIM(int2str(ig)), tr(iq)%keys)606 tr(iq)%gen0Name = tr(jq)%name; CALL addKey_s11('gen0Name', tr(iq)%gen0Name, tr(iq)%keys) 607 tr(iq)%iGeneration = ig; CALL addKey_s11('iGeneration', TRIM(int2str(ig)), tr(iq)%keys) 601 608 END DO 602 609 END FUNCTION setGeneration … … 723 730 ttr(it)%keys%name = TRIM(nam) !--- Name inside the keys decriptor 724 731 ttr(it)%phase = p !--- Single phase entry 725 CALL addKey_ 1('name', nam, ttr(it)%keys)726 CALL addKey_ 1('phase', p, ttr(it)%keys)732 CALL addKey_s11('name', nam, ttr(it)%keys) 733 CALL addKey_s11('phase', p, ttr(it)%keys) 727 734 IF(lExt .AND. tr(iq)%iGeneration>0) THEN 728 735 ttr(it)%parent = addPhase(tr(iq)%parent, p) 729 736 ttr(it)%gen0Name = addPhase(tr(iq)%gen0Name, p) 730 CALL addKey_ 1('parent', ttr(it)%parent, ttr(it)%keys)731 CALL addKey_ 1('gen0Name', ttr(it)%gen0Name, ttr(it)%keys)737 CALL addKey_s11('parent', ttr(it)%parent, ttr(it)%keys) 738 CALL addKey_s11('gen0Name', ttr(it)%gen0Name, ttr(it)%keys) 732 739 END IF 733 740 it = it+1 … … 1001 1008 INTEGER :: iq, ig, igen, ngen, ix(SIZE(tr)) 1002 1009 tr(:)%iqParent = strIdx( tr(:)%name, tr(:)%parent ) !--- Parent index 1003 DO iq = 1, SIZE(tr); CALL addKey_ 1('iqParent', int2str(tr(iq)%iqParent), tr(iq)%keys); END DO1010 DO iq = 1, SIZE(tr); CALL addKey_s11('iqParent', int2str(tr(iq)%iqParent), tr(iq)%keys); END DO 1004 1011 ngen = MAXVAL(tr(:)%iGeneration, MASK=.TRUE.) 1005 1012 DO iq = 1, SIZE(tr) … … 1013 1020 IF(igen == ig+1) THEN 1014 1021 tr(iq)%nqChildren = tr(iq)%nqDescen 1015 CALL addKey_ 1('nqChildren', int2str(tr(iq)%nqChildren), tr(iq)%keys)1022 CALL addKey_s11('nqChildren', int2str(tr(iq)%nqChildren), tr(iq)%keys) 1016 1023 END IF 1017 1024 END DO 1018 CALL addKey_ 1('iqDescen', strStack(int2str(tr(iq)%iqDescen)), tr(iq)%keys)1019 CALL addKey_ 1('nqDescen', int2str(tr(iq)%nqDescen) , tr(iq)%keys)1025 CALL addKey_s11('iqDescen', strStack(int2str(tr(iq)%iqDescen)), tr(iq)%keys) 1026 CALL addKey_s11('nqDescen', int2str(tr(iq)%nqDescen) , tr(iq)%keys) 1020 1027 END DO 1021 1028 END SUBROUTINE indexUpdate … … 1303 1310 !=== ADD THE <key>=<val> PAIR TO THE "ky[(:)]" KEY[S] DESCRIPTOR[S] OR THE <key>=<val(:)> PAIRS TO THE "ky(:)" KEYS DESCRIPTORS 1304 1311 !============================================================================================================================== 1305 SUBROUTINE addKey_ 1(key,val, ky, lOverWrite)1306 CHARACTER(LEN=*), INTENT(IN) :: key, val1312 SUBROUTINE addKey_s11(key, sval, ky, lOverWrite) 1313 CHARACTER(LEN=*), INTENT(IN) :: key, sval 1307 1314 TYPE(keys_type), INTENT(INOUT) :: ky 1308 1315 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite … … 1314 1321 IF(.NOT.ALLOCATED(ky%key)) THEN 1315 1322 ALLOCATE(ky%key(1)); ky%key(1)=key 1316 ALLOCATE(ky%val(1)); ky%val(1)= val1323 ALLOCATE(ky%val(1)); ky%val(1)=sval 1317 1324 RETURN 1318 1325 END IF … … 1320 1327 IF(iky == 0) THEN 1321 1328 nky = SIZE(ky%key) 1322 ALLOCATE(k(nky+1)); k(1:nky) = ky%key; k(nky+1) = key; ky%key = k1323 ALLOCATE(v(nky+1)); v(1:nky) = ky%val; v(nky+1) = val; ky%val = v1329 ALLOCATE(k(nky+1)); k(1:nky) = ky%key; k(nky+1) = key; ky%key = k 1330 ALLOCATE(v(nky+1)); v(1:nky) = ky%val; v(nky+1) = sval; ky%val = v 1324 1331 ELSE IF(lo) THEN 1325 ky%key(iky) = key; ky%val(iky) = val1332 ky%key(iky) = key; ky%val(iky) = sval 1326 1333 END IF 1327 END SUBROUTINE addKey_1 1328 !============================================================================================================================== 1329 SUBROUTINE addKey_m(key, val, ky, lOverWrite) 1330 CHARACTER(LEN=*), INTENT(IN) :: key, val 1334 END SUBROUTINE addKey_s11 1335 !============================================================================================================================== 1336 SUBROUTINE addKey_i11(key, ival, ky, lOverWrite) 1337 CHARACTER(LEN=*), INTENT(IN) :: key 1338 INTEGER, INTENT(IN) :: ival 1339 TYPE(keys_type), INTENT(INOUT) :: ky 1340 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite 1341 !------------------------------------------------------------------------------------------------------------------------------ 1342 CALL addKey_s11(key, int2str(ival), ky, lOverWrite) 1343 END SUBROUTINE addKey_i11 1344 !============================================================================================================================== 1345 SUBROUTINE addKey_r11(key, rval, ky, lOverWrite) 1346 CHARACTER(LEN=*), INTENT(IN) :: key 1347 REAL, INTENT(IN) :: rval 1348 TYPE(keys_type), INTENT(INOUT) :: ky 1349 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite 1350 !------------------------------------------------------------------------------------------------------------------------------ 1351 CALL addKey_s11(key, real2str(rval), ky, lOverWrite) 1352 END SUBROUTINE addKey_r11 1353 !============================================================================================================================== 1354 SUBROUTINE addKey_l11(key, lval, ky, lOverWrite) 1355 CHARACTER(LEN=*), INTENT(IN) :: key 1356 LOGICAL, INTENT(IN) :: lval 1357 TYPE(keys_type), INTENT(INOUT) :: ky 1358 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite 1359 !------------------------------------------------------------------------------------------------------------------------------ 1360 CALL addKey_s11(key, bool2str(lval), ky, lOverWrite) 1361 END SUBROUTINE addKey_l11 1362 !============================================================================================================================== 1363 !============================================================================================================================== 1364 SUBROUTINE addKey_s1m(key, sval, ky, lOverWrite) 1365 CHARACTER(LEN=*), INTENT(IN) :: key, sval 1331 1366 TYPE(keys_type), INTENT(INOUT) :: ky(:) 1332 1367 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite … … 1334 1369 INTEGER :: itr 1335 1370 DO itr = 1, SIZE(ky) 1336 CALL addKey_1(key, val, ky(itr), lOverWrite) 1337 END DO 1338 END SUBROUTINE addKey_m 1339 !============================================================================================================================== 1340 SUBROUTINE addKey_mm(key, val, ky, lOverWrite) 1341 CHARACTER(LEN=*), INTENT(IN) :: key, val(:) 1371 CALL addKey_s11(key, sval, ky(itr), lOverWrite) 1372 END DO 1373 END SUBROUTINE addKey_s1m 1374 !============================================================================================================================== 1375 SUBROUTINE addKey_i1m(key, ival, ky, lOverWrite) 1376 CHARACTER(LEN=*), INTENT(IN) :: key 1377 INTEGER, INTENT(IN) :: ival 1342 1378 TYPE(keys_type), INTENT(INOUT) :: ky(:) 1343 1379 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite 1344 1380 !------------------------------------------------------------------------------------------------------------------------------ 1345 1381 INTEGER :: itr 1346 DO itr = 1, SIZE(ky); CALL addKey_1(key, val(itr), ky(itr), lOverWrite); END DO 1347 END SUBROUTINE addKey_mm 1382 DO itr = 1, SIZE(ky) 1383 CALL addKey_s11(key, int2str(ival), ky(itr), lOverWrite) 1384 END DO 1385 END SUBROUTINE addKey_i1m 1386 !============================================================================================================================== 1387 SUBROUTINE addKey_r1m(key, rval, ky, lOverWrite) 1388 CHARACTER(LEN=*), INTENT(IN) :: key 1389 REAL, INTENT(IN) :: rval 1390 TYPE(keys_type), INTENT(INOUT) :: ky(:) 1391 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite 1392 !------------------------------------------------------------------------------------------------------------------------------ 1393 INTEGER :: itr 1394 DO itr = 1, SIZE(ky) 1395 CALL addKey_s11(key, real2str(rval), ky(itr), lOverWrite) 1396 END DO 1397 END SUBROUTINE addKey_r1m 1398 !============================================================================================================================== 1399 SUBROUTINE addKey_l1m(key, lval, ky, lOverWrite) 1400 CHARACTER(LEN=*), INTENT(IN) :: key 1401 LOGICAL, INTENT(IN) :: lval 1402 TYPE(keys_type), INTENT(INOUT) :: ky(:) 1403 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite 1404 !------------------------------------------------------------------------------------------------------------------------------ 1405 INTEGER :: itr 1406 DO itr = 1, SIZE(ky) 1407 CALL addKey_s11(key, bool2str(lval), ky(itr), lOverWrite) 1408 END DO 1409 END SUBROUTINE addKey_l1m 1410 !============================================================================================================================== 1411 !============================================================================================================================== 1412 SUBROUTINE addKey_smm(key, sval, ky, lOverWrite) 1413 CHARACTER(LEN=*), INTENT(IN) :: key, sval(:) 1414 TYPE(keys_type), INTENT(INOUT) :: ky(:) 1415 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite 1416 !------------------------------------------------------------------------------------------------------------------------------ 1417 INTEGER :: itr 1418 DO itr = 1, SIZE(ky); CALL addKey_s11(key, sval(itr), ky(itr), lOverWrite); END DO 1419 END SUBROUTINE addKey_smm 1420 !============================================================================================================================== 1421 SUBROUTINE addKey_imm(key, ival, ky, lOverWrite) 1422 CHARACTER(LEN=*), INTENT(IN) :: key 1423 INTEGER, INTENT(IN) :: ival(:) 1424 TYPE(keys_type), INTENT(INOUT) :: ky(:) 1425 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite 1426 !------------------------------------------------------------------------------------------------------------------------------ 1427 INTEGER :: itr 1428 DO itr = 1, SIZE(ky); CALL addKey_s11(key, int2str(ival(itr)), ky(itr), lOverWrite); END DO 1429 END SUBROUTINE addKey_imm 1430 !============================================================================================================================== 1431 SUBROUTINE addKey_rmm(key, rval, ky, lOverWrite) 1432 CHARACTER(LEN=*), INTENT(IN) :: key 1433 REAL, INTENT(IN) :: rval(:) 1434 TYPE(keys_type), INTENT(INOUT) :: ky(:) 1435 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite 1436 !------------------------------------------------------------------------------------------------------------------------------ 1437 INTEGER :: itr 1438 DO itr = 1, SIZE(ky); CALL addKey_s11(key, real2str(rval(itr)), ky(itr), lOverWrite); END DO 1439 END SUBROUTINE addKey_rmm 1440 !============================================================================================================================== 1441 SUBROUTINE addKey_lmm(key, lval, ky, lOverWrite) 1442 CHARACTER(LEN=*), INTENT(IN) :: key 1443 LOGICAL, INTENT(IN) :: lval(:) 1444 TYPE(keys_type), INTENT(INOUT) :: ky(:) 1445 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite 1446 !------------------------------------------------------------------------------------------------------------------------------ 1447 INTEGER :: itr 1448 DO itr = 1, SIZE(ky); CALL addKey_s11(key, bool2str(lval(itr)), ky(itr), lOverWrite); END DO 1449 END SUBROUTINE addKey_lmm 1348 1450 !============================================================================================================================== 1349 1451 … … 1362 1464 DO ik = 1, SIZE(t(jd)%keys%key) 1363 1465 CALL get_in(t(jd)%keys%key(ik), val, '*none*') 1364 IF(val /= '*none*') CALL addKey_ 1(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.)1466 IF(val /= '*none*') CALL addKey_s11(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.) 1365 1467 END DO 1366 1468 END SUBROUTINE addKeysFromDef … … 1821 1923 1822 1924 !============================================================================================================================== 1925 !=== APPEND TRACERS DATABASE "tracs" WITH TRACERS/KEYS "tname"/"keys" ; SAME FOR INTERNAL DATABASE "tracers" ================== 1926 !============================================================================================================================== 1927 SUBROUTINE addTracer_1(tname, keys, tracs) 1928 CHARACTER(LEN=*), INTENT(IN) :: tname 1929 TYPE(keys_type), INTENT(IN) :: keys 1930 TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tracs(:) 1931 TYPE(trac_type), ALLOCATABLE :: tr(:) 1932 INTEGER :: nt, ix 1933 IF(ALLOCATED(tracs)) THEN 1934 nt = SIZE(tracs) 1935 ix = strIdx(tracs(:)%name, tname) 1936 CALL msg('Modifying existing tracer "'//TRIM(tname)//'"', modname, ix /= 0) 1937 CALL msg('Appending with tracer "' //TRIM(tname)//'"', modname, ix == 0) 1938 IF(ix == 0) THEN 1939 ix = nt+1; ALLOCATE(tr(nt+1)); tr(1:nt) = tracs(1:nt); CALL MOVE_ALLOC(FROM=tr, TO=tracs) 1940 END IF 1941 ELSE 1942 CALL msg('Creating a tracer descriptor with tracer "'//TRIM(tname)//'"', modname) 1943 ix = 1; ALLOCATE(tracs(1)) 1944 END IF 1945 tracs(ix)%name = tname 1946 tracs(ix)%keys = keys 1947 END SUBROUTINE addTracer_1 1948 !============================================================================================================================== 1949 SUBROUTINE addTracer_1def(tname, keys) 1950 CHARACTER(LEN=*), INTENT(IN) :: tname 1951 TYPE(keys_type), INTENT(IN) :: keys 1952 CALL addTracer_1(tname, keys, tracers) 1953 END SUBROUTINE addTracer_1def 1954 !============================================================================================================================== 1955 1956 1957 !============================================================================================================================== 1958 LOGICAL FUNCTION delTracer_1(tname, tracs) RESULT(lerr) 1959 CHARACTER(LEN=*), INTENT(IN) :: tname 1960 TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: tracs(:) 1961 TYPE(trac_type), ALLOCATABLE :: tr(:) 1962 INTEGER :: nt, ix 1963 lerr = .NOT.ALLOCATED(tracs) 1964 IF(fmsg('Can''t remove tracer "'//TRIM(tname)//'" from an empty tracers descriptor', modname, lerr)) RETURN 1965 nt = SIZE(tracs) 1966 ix = strIdx(tracs(:)%name, tname) 1967 CALL msg('Removing tracer "' //TRIM(tname)//'"', modname, ix /= 0) 1968 CALL msg('Can''t remove unknown tracer "'//TRIM(tname)//'"', modname, ix == 0) 1969 IF(ix /= 0) THEN 1970 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) 1971 END IF 1972 END FUNCTION delTracer_1 1973 !============================================================================================================================== 1974 LOGICAL FUNCTION delTracer_1def(tname) RESULT(lerr) 1975 CHARACTER(LEN=*), INTENT(IN) :: tname 1976 lerr = delTracer(tname, tracers) 1977 END FUNCTION delTracer_1def 1978 !============================================================================================================================== 1979 1980 1981 !============================================================================================================================== 1823 1982 !=== GET PHASE INDEX IN THE POSSIBLE PHASES LIST OR IN A SPECIFIED LIST ("phases") ============================================ 1824 1983 !============================================================================================================================== -
LMDZ6/trunk/libf/misc/strings_mod.F90
r4454 r4987 1341 1341 !=== Convert a string into a logical/integer integer or an integer/real into a string ========================================= 1342 1342 !============================================================================================================================== 1343 ELEMENTAL LOGICAL FUNCTION str2bool(str) RESULT(out) 1343 ELEMENTAL INTEGER FUNCTION str2bool(str) RESULT(out) !--- Result: 0/1 for .FALSE./.TRUE., -1 if not a valid boolean 1344 IMPLICIT NONE 1344 1345 CHARACTER(LEN=*), INTENT(IN) :: str 1345 1346 INTEGER :: ierr 1346 READ(str,*,IOSTAT=ierr) out 1347 IF(ierr==0) RETURN 1348 out = ANY(['t ','true ','.true.','y ','yes ']==strLower(str)) 1347 LOGICAL :: lout 1348 READ(str,*,IOSTAT=ierr) lout 1349 out = -HUGE(1) 1350 IF(ierr /= 0) THEN 1351 IF(ANY(['.false.', 'false ', 'no ', 'f ', 'n '] == strLower(str))) out = 0 1352 IF(ANY(['.true. ', 'true ', 'yes ', 't ', 'y '] == strLower(str))) out = 1 1353 ELSE 1354 out = 0; IF(lout) out = 1 1355 END IF 1349 1356 END FUNCTION str2bool 1350 1357 !==============================================================================================================================
Note: See TracChangeset
for help on using the changeset viewer.
