- Timestamp:
- May 11, 2021, 2:10:34 PM (3 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/branches/LMDZ-tracers/libf/misc/readTracFiles_mod.f90
r3852 r3891 1 1 MODULE readTracFiles_mod 2 2 3 USE strings_mod, ONLY: msg, testFile, strFind, strStack, strCount, strHead, removeComment, dispTable, fmsg, &4 cat, checkList, strIdx, strParse, strReplace, strTail, reduceExpr, modname, find, test3 USE strings_mod, ONLY: msg, testFile, strFind, strStack, strReduce, strHead, strCount, find, dispTable, fmsg, & 4 removeComment, cat, checkList, strIdx, strParse, strReplace, strTail, reduceExpr, test, modname, get_in 5 5 USE trac_types_mod, ONLY : tra, iso, db, kys 6 6 … … 9 9 PRIVATE 10 10 11 PUBLIC :: initIsotopes 11 12 PUBLIC :: readTracersFiles, aliasTracer, tracersSubset, indexUpdate !--- TOOLS ASSOCIATED TO TRACERS DESCRIPTORS 12 13 PUBLIC :: readIsotopesFile !--- TOOLS ASSOCIATED TO ISOTOPES DESCRIPTORS … … 82 83 !------------------------------------------------------------------------------------------------------------------------------ 83 84 lerr = .FALSE. 84 modname = 'readTracersFiles'85 ! modname = 'readTracersFiles' 85 86 IF(.NOT.ALLOCATED(dBase)) ALLOCATE(dBase(0)) 86 87 … … 225 226 CHARACTER(LEN=256), ALLOCATABLE :: sec(:) 226 227 INTEGER, ALLOCATABLE :: ix(:) 227 INTEGER :: n0, idb, ndb 228 INTEGER :: n0, idb, ndb, i, j 228 229 LOGICAL :: ll 229 230 !------------------------------------------------------------------------------------------------------------------------------ … … 272 273 ll = strParse(str,' ', keys = s, vals = v, n = n) !--- Parse <key>=<val> pairs 273 274 tt = dBase(ndb)%trac(:) 274 tmp%name = s(1); tmp% keys = kys(s(1), s(2:n), v(2:n))275 tmp%name = s(1); tmp%comp=secn; tmp%keys = kys(s(1), s(2:n), v(2:n)) 275 276 dBase(ndb)%trac = [tt(:), tmp] 276 277 DEALLOCATE(tt) … … 294 295 TYPE(tra), ALLOCATABLE, TARGET, INTENT(INOUT) :: t(:) 295 296 CHARACTER(LEN=*), INTENT(IN) :: defName 296 INTEGER :: i0, it, k297 TYPE(kys), POINTER :: k0297 INTEGER :: jd, it, k 298 TYPE(kys), POINTER :: ky 298 299 TYPE(tra), ALLOCATABLE :: tt(:) 299 i0= strIdx(t(:)%name, defName)300 IF( i0== 0) RETURN301 k 0 => t(i0)%keys302 DO k = 1, SIZE(k 0%key) !--- Loop on the keys of the tracer named "defName"303 CALL addKey_ tra(TRIM(k0%key(k)), TRIM(k0%val(k)), t)!--- Add key to all the tracers (no overwriting)304 END DO 305 tt = [t(1: i0-1),t(i0+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t) !--- Remove the virtual tracer named "defName"300 jd = strIdx(t(:)%name, defName) 301 IF(jd == 0) RETURN 302 ky => t(jd)%keys 303 DO k = 1, SIZE(ky%key) !--- Loop on the keys of the tracer named "defName" 304 CALL addKey_m(ky%key(k), ky%val(k), t(:)%keys) !--- Add key to all the tracers (no overwriting) 305 END DO 306 tt = [t(1:jd-1),t(jd+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t) !--- Remove the virtual tracer named "defName" 306 307 END SUBROUTINE addDefault 307 308 !============================================================================================================================== … … 338 339 339 340 340 341 342 341 !============================================================================================================================== 343 342 LOGICAL FUNCTION expandSection(tr, sname, fname) RESULT(lerr) … … 451 450 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname !--- File name 452 451 CHARACTER(LEN=256) :: mesg 453 CHARACTER(LEN=256) :: bp(SIZE(tr, DIM=1)), pha 452 CHARACTER(LEN=256) :: bp(SIZE(tr, DIM=1)), pha !--- Bad phases list, phases of current tracer 454 453 CHARACTER(LEN=1) :: p 455 454 INTEGER :: ip, np, iq, nq … … 814 813 815 814 !============================================================================================================================== 816 !=== READ THE ISOTOPES NAMED "iso" FROM THE TRACERS SECTIONS "tr" IN THE FILE "fnam" ; PUT RESULT IN A TRACERS DESCRIPTOR ==== 817 !=== * SYNTAX IS THE SAME AS IN THE "tracer.def" FILE ; EACH TRACER SECTION CONTAINS ONE LINE EACH OF ITS KNOWN ISOTOPES ==== 818 !=== * EACH TRACERS SECTION CAN CONTAIN A "params" VIRTUAL ISOTOPE LINE CONTAINING DEFAULT PARAMETERS FOR THE ISOTOPES ==== 819 !=== * IF SOME KEYS ARE FOUND BOTH IN THE "*.def" FILES AND THE "params" SECTION, TEH VALUE FROM "*.def" FILE IS RETAINED ==== 820 !=== * ON EACH ISOTOPE LINE, A DEFINED KEY CAN BE USED IN THE OTHER KEYS AS A PARAMETER (SIGNLE LEVEL DEPENDENCY !) ==== 821 !=== * THE DIFFERENT ISOTOPES SETS (ONE EACH PARENT TRACER) ARE MERGED INTO A SINGLE TRACERS DESCRIPTOR VECTOR ==== 822 !=== * THE ROUTINE GIVES AN ERROR IF A REQUIRED ISOTOPE IS NOT AVAILABLE IN THE DATABASE STORED IN "fnam" ==== 823 !============================================================================================================================== 824 815 !=== READ FILE "fnam" TO APPEND THE "dBase" TRACERS DATABASE WITH AS MUCH SECTIONS AS PARENTS NAMES IN "isot(:)%prnt": ==== 816 !=== * Each section dBase(i)%name contains the isotopes "dBase(i)%trac(:)" descending on "dBase(i)%name"="iso(i)%prnt" ==== 817 !=== * For each isotopes class, the <key>=<val> vector of each tracer is moved into the isotopes descriptor "isot" ==== 818 !=== NOTES: ==== 819 !=== * Most of the "isot" components have been defined in the calling routine (initIsotopes): ==== 820 !=== prnt, nzon, zone(:), niso, keys(:)%name, nitr, trac(:), npha, phas, iTraPha(:,:), iZonPhi(:,:) ==== 821 !=== * Same syntax for isotopes file and "tracer.def": a tracers section contains one line for each of its isotopes ==== 822 !=== * Each tracers section can contain a "params" virtual isotope line of isotopes parameters default values ==== 823 !=== * In case keys are found both in the "params" section and the "*.def" file, the later value is retained ==== 824 !=== * On each isotope line, defined keys can be used for other keys defintions (single level depth substitution) ==== 825 !=== * The routine gives an error if a required isotope is not available in the database stored in "fnam" ==== 826 !============================================================================================================================== 825 827 LOGICAL FUNCTION readIsotopesFile(fnam, isot) RESULT(lerr) 826 828 CHARACTER(LEN=*), INTENT(IN) :: fnam !--- Input file name 827 829 TYPE(iso), TARGET, INTENT(INOUT) :: isot(:) !--- Isotopes descriptors (field "prnt" must be defined !) 828 INTEGER :: ik, is, it, idb, nk0, i 830 INTEGER :: ik, is, it, idb, nk0, i, iis 829 831 INTEGER :: nk, ns, nt, ndb, nb0, i0 830 832 CHARACTER(LEN=256), POINTER :: k(:), v(:), k0(:), v0(:) … … 832 834 CHARACTER(LEN=256) :: val 833 835 TYPE(kys), POINTER :: ky(:) 834 TYPE(tra), POINTER :: t(:) 835 TYPE(tra), ALLOCATABLE :: tt(:) 836 TYPE(tra), POINTER :: tt(:), t 836 837 TYPE(db), ALLOCATABLE :: tdb(:) 837 838 LOGICAL, ALLOCATABLE :: liso(:) … … 844 845 IF(test(readSections(fnam,strStack(isot(:)%prnt,',')),lerr)) RETURN!--- Read sections, one each parent tracer 845 846 ndb = SIZE(dBase, DIM=1) !--- Current database size 846 847 847 DO idb = nb0, ndb 848 t => dBase(idb)%trac(:) 849 nt = SIZE(t) !--- Number of isotopes in the current database section 850 851 PRINT* 852 PRINT*,'AVANT:' 853 DO it=1,SIZE(t); print*,TRIM(t(it)%name)//': '//strStack([(TRIM(t(it)%keys%key(i))//'='//TRIM(t(it)%keys%val(i)), i=1, SIZE(t(it)%keys%key))]); END DO 848 iis = idb-nb0+1 849 854 850 !--- GET FEW GLOBAL KEYS FROM "def" FILES AND ADD THEM TO THE 'params' SECTION 855 851 CALL addKeysFromDef(dBase(idb)%trac, 'params') … … 858 854 CALL subDefault(dBase(idb)%trac, 'params', .TRUE.) 859 855 860 PRINT* 861 PRINT*,'AVANT REDUCTION:' 862 t => dBase(idb)%trac(:) 863 DO it=1,SIZE(t); print*,TRIM(t(it)%name)//': '//strStack([(TRIM(t(it)%keys%key(i))//'='//TRIM(t(it)%keys%val(i)), i=1, SIZE(t(it)%keys%key))]); END DO 864 865 !--- REDUCE THE EXPRESSIONS TO OBTAIN SCALARS 866 DO it=1, nt 867 v => dBase(idb)%trac(it)%keys%val(:) 868 WHERE(reduceExpr(v, vals)) v = vals 856 tt => dBase(idb)%trac 857 858 !--- REDUCE THE EXPRESSIONS TO OBTAIN SCALARS AND TRANSFER THEM TO THE "isot" ISOTOPES DESCRIPTORS VECTOR 859 DO it = 1, SIZE(dBase(idb)%trac) 860 is = strIdx(isot(iis)%keys(:)%name, dBase(idb)%trac(it)%name) !--- Index of the "isot(iis)%keys(:)%name" tracer named "t%name" 861 IF(is == 0) CYCLE 862 t => dBase(idb)%trac(it) 863 liso = reduceExpr(t%keys%val, vals) !--- Reduce expressions (for substituted variables) 864 isot(iis)%keys(is)%key = PACK(t%keys%key, MASK=liso) 865 isot(iis)%keys(is)%val = PACK( vals, MASK=liso) 869 866 END DO 870 867 871 PRINT*872 PRINT*,'APRES:'873 t => dBase(idb)%trac(:)874 DO it=1,SIZE(t); print*,TRIM(t(it)%name)//': '//strStack([(TRIM(t(it)%keys%key(i))//'='//TRIM(t(it)%keys%val(i)), i=1, SIZE(t(it)%keys%key))]); END DO875 876 !--- TRANSFER THE key=val PAIRS TO THE ISOTOPES DESCRIPTOR877 print*878 print*,'isot%prnt = '//strStack(isot%prnt)879 880 ky => isot(strIdx(isot(:)%prnt, dBase(idb)%name))%keys !--- Keys of "isot" tracers with parent "dBase(idb)%name"881 print*,'ky%name = '//strStack(ky%name)882 is=1883 DO it = 1, nt; IF(it == i0) CYCLE884 print*,'AAAAAA '//strStack(ky%name)885 print*,' '//TRIM(t(it)%name)886 is = strIdx(ky(:)%name, t(it)%name) !--- Index of the "isot(:)" tracer named "t(it)%name"887 IF(is == 0) CYCLE !--- Current isotope is not present in "isot" => not needed888 k => ky(is)%key; k = t(it)%keys%key889 v => ky(is)%val; v = t(it)%keys%val890 WHERE(reduceExpr(v, vals)) v = vals891 DO ik=1, SIZE(k); IF(reduceExpr(v(ik),val)) v(ik) = val; END DO!--- Reduce operations (for substituted variables)892 print*,'(4) '//strStack([(TRIM(k(i))//'='//TRIM(v(i)), i=1, SIZE(k))])893 END DO894 print*,'(7) i0=',i0895 896 868 !--- CHECK FOR MISSING ISOTOPES (NO KEYS ALLOCATED) 897 liso = [( ALLOCATED(ky(is)%key), is=1, SIZE(ky) )] 898 print*,'liso=',liso 899 IF(test(checkList(ky(:)%name, & 900 .NOT.liso, 'Check file "'//TRIM(fnam)//'" in section "'//TRIM(dBase(idb)%name)//'"', 'isotopes', 'missing'),lerr)) RETURN 869 liso = [( ALLOCATED(isot(iis)%keys(is)%key), is=1, SIZE(isot(iis)%keys) )] 870 IF(test(checkList(isot(iis)%keys(:)%name, .NOT.liso, & 871 'Check file "'//TRIM(fnam)//'" in section "'//TRIM(dBase(idb)%name)//'"', 'isotopes', 'missing'),lerr)) RETURN 901 872 END DO 902 873 … … 907 878 ALLOCATE(tdb(nb0-1)); tdb(1:nb0-1)=dBase(1:nb0-1); CALL MOVE_ALLOC(FROM=tdb, TO=dBase) 908 879 END IF 909 lerr = dispIsotopes(isot, 'isotopes parameters read from file')880 lerr = dispIsotopes(isot, 'Isotopes parameters read from file') 910 881 911 882 END FUNCTION readIsotopesFile 912 883 !============================================================================================================================== 884 885 !============================================================================================================================== 886 !=== IF ISOTOPES (2ND GENERATION TRACERS) ARE DETECTED: === 887 !=== * COMPUTE MOST OF THE RELATED QUANTITIES ("isot" COMPONENTS). === 888 !=== * COMPUTE FEW ISOTOPES-DEDICATED "trac" COMPONENTS === 889 !=== * CALL readIsotopesFile TO GET PHYSICAL QUANTITIES (<key>=<val> PAIRS) === 890 !=== NOTE: THIS IS DONE HERE (IN A ROUTINE CALLED BY THE DYNAMIC), BECAUSE THE DYNAMIC NEEDS FEW PHYSICAL PARAMETERS. === 891 !============================================================================================================================== 892 SUBROUTINE initIsotopes(trac, isot) 893 TYPE(tra), ALLOCATABLE, TARGET, INTENT(INOUT) :: trac(:) 894 TYPE(iso), ALLOCATABLE, TARGET, INTENT(INOUT) :: isot(:) 895 CHARACTER(LEN=256), ALLOCATABLE :: p(:), str(:) !--- Temporary storage 896 CHARACTER(LEN=256) :: iname 897 CHARACTER(LEN=1) :: ph !--- Phase 898 INTEGER :: nbIso, ic, ip, iq, it, iz 899 LOGICAL, ALLOCATABLE :: ll(:) !--- Mask 900 TYPE(tra), POINTER :: t(:), t1 901 TYPE(iso), POINTER :: s 902 903 t => trac 904 905 p = PACK(delPhase(t%prnt), MASK = t%type=='tracer' .AND. t%igen==2)!--- Parents of 2nd generation isotopes 906 CALL strReduce(p, nbIso) 907 ALLOCATE(isot(nbIso)) 908 909 IF(nbIso==0) RETURN !=== NO ISOTOPES: FINISHED 910 911 !--- ISOTOPES RELATED VARIABLES ; NULL OR EMPTY IF NO ISOTOPES 912 isot(:)%prnt = p 913 DO ic = 1, SIZE(p) !--- Loop on isotopes classes 914 s => isot(ic) 915 iname = s%prnt !--- Current isotopes class name (parent tracer name) 916 917 !=== Isotopes childs of tracer "iname": mask, names, number (same for each phase of "iname") 918 ll = t(:)%type=='tracer' .AND. delPhase(t(:)%prnt) == iname .AND. t(:)%phas == 'g' 919 str = PACK(delPhase(t(:)%name), MASK = ll) !--- Effectively found isotopes of "iname" 920 s%niso = SIZE(str) !--- Number of "effectively found isotopes of "iname" 921 ALLOCATE(s%keys(s%niso)) 922 FORALL(it = 1:s%niso) s%keys(it)%name = str(it) 923 924 !=== Geographic tagging tracers descending on tracer "iname": mask, names, number 925 ll = t(:)%type=='tag' .AND. delPhase(t(:)%nam1) == iname .AND. t(:)%igen == 3 926 s%zone = PACK(strTail(t(:)%name,'_'), MASK = ll) !--- Tagging zones names for isotopes category "iname" 927 CALL strReduce(s%zone) 928 s%nzon = SIZE(s%zone) !--- Tagging zones number for isotopes category "iname" 929 930 !=== Geographic tracers of the isotopes childs of tracer "iname" (same for each phase of "iname") 931 ! NOTE: One might like to create a similar variable for 2nd generation tagging tracers (tagging the gen1 tracers) 932 str = PACK(delPhase(t(:)%name), MASK=ll) 933 CALL strReduce(str) 934 s%nitr = s%niso + SIZE(str) !--- Number of isotopes + their geographic tracers [ntraciso] 935 ALLOCATE(s%trac(s%nitr)) 936 FORALL(it = 1:s%niso) s%trac(it) = s%keys(it)%name 937 FORALL(it = s%niso+1:s%nitr) s%trac(it) = str(it-s%niso) 938 939 !=== Phases for tracer "iname" 940 s%phas = '' 941 DO ip = 1, nphases; ph = known_phases(ip:ip); IF(strIdx(t%name,addPhase(iname, ph)) /= 0) s%phas = TRIM(s%phas)//ph; END DO 942 s%npha = LEN_TRIM(s%phas) !--- Equal to "nqo" for water 943 944 !=== Tables giving the index in a table of effectively found items for each dynamical tracer (1<=iq<=nqtot) 945 DO iq = 1, SIZE(t) 946 t1 => trac(iq) 947 IF(delPhase(t1%nam1) /= iname) CYCLE !--- Only deal with tracers descending on "iname" 948 t1%iso_igr = ic !--- Isotopes family idx in list "isotopes(:)%prnt" 949 t1%iso_num = strIdx(s%trac, delPhase(strHead(t1%name,'_'))) !--- Current isotope idx in effective isotopes list 950 t1%iso_zon = strIdx(s%zone, strTail(t1%name,'_') ) !--- Current isotope zone idx in effective zones list 951 t1%iso_pha = INDEX(s%phas,TRIM(t1%phas)) !--- Current isotope phase idx in effective phases list 952 IF(t1%igen /= 3) t1%iso_zon = 0 !--- Skip possible generation 2 tagging tracers 953 END DO 954 955 !=== Table used to get iq (index in dyn array, size nqtot) from the isotope and phase indexes ; the full isotopes list 956 ! (including tagging tracers) is sorted this way: iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN 957 s%iTraPha = RESHAPE( [( (strIdx(t(:)%name, addPhase(s%trac(it),s%phas(ip:ip))), it=1, s%nitr), ip=1, s%npha)], & 958 [s%nitr, s%npha] ) 959 960 !=== Table used to get ix (index in tagging tracers isotopes list, size nitr) from the zone and isotope indexes 961 s%iZonIso = RESHAPE( [( (strIdx(s%trac(:), TRIM(s%trac(it))//'_'//TRIM(s%zone(iz))), iz=1, s%nzon), it=1, s%niso)], & 962 [s%nzon, s%niso] ) 963 END DO 964 965 !=== Indexes, in dynamical tracers list, of the tracers transmitted to phytrac (nqtottr non-vanishing elements) 966 ll = delPhase(t%name)/='H2O' .AND. t%iso_num ==0 !--- Mask of tracers passed to the physics 967 t(:)%itr = UNPACK([(iq,iq=1,COUNT(ll))], ll, [(0, iq=1, SIZE(t))]) 968 969 !=== READ PHYSICAL PARAMETERS FROM "isotopes_params.def" FILE 970 ! DONE HERE, AND NOT ONLY IN "infotrac_phy", BECAUSE SOME PHYSICAL PARAMS ARE NEEDED FOR RESTARTS (tnat AND alpha_ideal) 971 IF(readIsotopesFile('isotopes_params.def',isot)) CALL abort_gcm(modname,'Problem when reading isotopes parameters',1) 972 973 END SUBROUTINE initIsotopes 974 !============================================================================================================================== 975 913 976 914 977 !============================================================================================================================== … … 955 1018 IF(iky == 0) THEN 956 1019 nky = SIZE(ky%key) 957 IF(nky == 0) THEN 958 ky%key = TRIM(key); ky%val = TRIM(val) 959 ELSE 960 ALLOCATE(k(nky+1)); k(1:nky) = ky%key; k(nky+1) = TRIM(key); CALL MOVE_ALLOC(FROM=k, TO=ky%key) 961 ALLOCATE(v(nky+1)); v(1:nky) = ky%val; v(nky+1) = TRIM(val); CALL MOVE_ALLOC(FROM=v, TO=ky%val) 962 END IF 1020 IF(nky == 0) THEN; ky%key = [key]; ky%val = [val]; ELSE; ky%key = [ky%key, key]; ky%val = [ky%val, val]; END IF 963 1021 ELSE IF(lo) THEN !--- Overwriting 964 ky%key(iky) = TRIM(key); ky%val(iky) = TRIM(val)1022 ky%key(iky) = key; ky%val(iky) = val 965 1023 END IF 966 1024 END SUBROUTINE addKey_1 967 1025 !============================================================================================================================== 968 SUBROUTINE addKey_tra(key, val, tr, lOverWrite, tname) 969 !------------------------------------------------------------------------------------------------------------------------------ 970 ! Purpose: Add the <key>=<val> pair in all the components of the "tr(itr)%keys" keys descriptor: 971 ! * "tname" specified: for the index "itr" of the tracer named "tname" 972 ! * "tname" unspecified: for all the tracers 973 !------------------------------------------------------------------------------------------------------------------------------ 974 CHARACTER(LEN=*), INTENT(IN) :: key, val 975 TYPE(tra), INTENT(INOUT) :: tr(:) 976 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite 977 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: tname 1026 SUBROUTINE addKey_m(key, val, ky, lOverWrite) 1027 !------------------------------------------------------------------------------------------------------------------------------ 1028 ! Purpose: Add the <key>=<val> pair in all the components of the "ky" keys descriptor. 1029 !------------------------------------------------------------------------------------------------------------------------------ 1030 CHARACTER(LEN=*), INTENT(IN) :: key, val 1031 TYPE(kys), INTENT(INOUT) :: ky(:) 1032 LOGICAL, OPTIONAL, INTENT(IN) :: lOverWrite 978 1033 INTEGER :: itr 979 1034 LOGICAL :: lo 980 1035 !------------------------------------------------------------------------------------------------------------------------------ 981 1036 lo=.FALSE.; IF(PRESENT(lOverWrite)) lo=lOverWrite 982 IF(PRESENT(tname)) THEN 983 itr = strIdx(tr%name, tname) 984 IF(itr == 0) RETURN 985 CALL addKey_1(key, val, tr(itr)%keys, lo) 986 ELSE 987 DO itr = 1, SIZE(tr); CALL addKey_1(key, val, tr(itr)%keys, lo); END DO 988 END IF 989 END SUBROUTINE addKey_tra 990 !============================================================================================================================== 991 SUBROUTINE addKeysFromDef(tr, tr0) 992 USE ioipsl_getin_p_mod, ONLY : getin_p 993 TYPE(tra), ALLOCATABLE, INTENT(INOUT) :: tr(:) 1037 DO itr = 1, SIZE(ky); CALL addKey_1(key, val, ky(itr), lo); END DO 1038 END SUBROUTINE addKey_m 1039 !============================================================================================================================== 1040 SUBROUTINE addKeysFromDef(t, tr0) 1041 !------------------------------------------------------------------------------------------------------------------------------ 1042 ! Purpose: The values of the keys of the tracer named "tr0" are overwritten by the values found in the *.def files, if any. 1043 !------------------------------------------------------------------------------------------------------------------------------ 1044 TYPE(tra), ALLOCATABLE, INTENT(INOUT) :: t(:) 994 1045 CHARACTER(LEN=*), INTENT(IN) :: tr0 995 1046 CHARACTER(LEN=256) :: val 996 INTEGER :: ik, i0997 i0 = strIdx(tr%name, tr0)998 IF( i0== 0) RETURN999 DO ik = 1, SIZE(t r(i0)%keys%key)1000 val = 'zzzz'; CALL getin_p(tr(i0)%keys%key(ik), val)1001 IF(val /= 'zzzz') CALL addKey_1(t r(i0)%keys%key(ik), val, tr(i0)%keys, .TRUE.)1047 INTEGER :: ik, jd 1048 jd = strIdx(t%name, tr0) 1049 IF(jd == 0) RETURN 1050 DO ik = 1, SIZE(t(jd)%keys%key) 1051 CALL get_in(t(jd)%keys%key(ik), val, 'zzzz') 1052 IF(val /= 'zzzz') CALL addKey_1(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.) 1002 1053 END DO 1003 1054 END SUBROUTINE addKeysFromDef … … 1064 1115 LOGICAL FUNCTION getKeyByName_s1(keyn, val, tname, ky) RESULT(lerr) 1065 1116 !--- Purpose: Get the value of the key named "keyn" for the tracer named "tnam". 1066 ! * "ky" unspecified: try in "tracers" for "tnam" with phase suffix, then in "isotopes" without.1067 ! * "ky" specified: try in "ky" for "tnam" with , then without phase suffix.1117 ! * "ky" unspecified: try in "tracers" for "tnam" with phase and tagging suffixes, then in "isotopes" without. 1118 ! * "ky" specified: try in "ky" for "tnam" with phase and tagging suffixes, then without. 1068 1119 ! The returned error code is always .FALSE.: an empty string is returned when the key hasn't been found. 1069 1120 CHARACTER(LEN=*), INTENT(IN) :: keyn … … 1074 1125 lerr = .FALSE. 1075 1126 IF(PRESENT(ky)) THEN 1076 val = getKeyByName_prv(keyn, tname , ky); IF(val /= '') RETURN!--- "ky" and "tnam"1077 val = getKeyByName_prv(keyn, delPhase( tname), ky)!--- "ky" and "tnam" without phase1127 val = getKeyByName_prv(keyn, tname , ky); IF(val /= '') RETURN !--- "ky" and "tnam" 1128 val = getKeyByName_prv(keyn, delPhase(strHead(tname,'_')), ky) !--- "ky" and "tnam" without phase 1078 1129 ELSE 1079 1130 IF(.NOT.ALLOCATED(tracers)) RETURN … … 1081 1132 IF(.NOT.ALLOCATED(isotopes)) RETURN 1082 1133 IF(SIZE(isotopes) == 0) RETURN 1083 DO is = 1, SIZE(isotopes); IF(strIdx(isotopes(is)%keys(:)%name, tname) /= 0) EXIT; END DO1134 DO is = 1, SIZE(isotopes); IF(strIdx(isotopes(is)%keys(:)%name, delPhase(strHead(tname,'_'))) /= 0) EXIT; END DO 1084 1135 IF(is /= 0) val = getKeyByName_prv(keyn, tname, isotopes(is)%keys(:)) !--- "isotopes" and "tnam" without phase 1085 1136 END IF … … 1175 1226 ELEMENTAL CHARACTER(LEN=256) FUNCTION delPhase(s) RESULT(out) 1176 1227 CHARACTER(LEN=*), INTENT(IN) :: s 1177 INTEGER :: l 1228 INTEGER :: l, i 1178 1229 out = s 1179 1230 IF(s == '') RETURN 1180 l=LEN_TRIM(s) 1181 IF(s(l-1:l-1)=='-' .AND. INDEX(known_phases,s(l:l))/=0) out = s(1:l-2) 1231 i = INDEX(s, '_'); l = LEN_TRIM(s) 1232 IF(i == 0) THEN 1233 IF(s(l-1:l-1)=='-' .AND. INDEX(known_phases,s(l:l)) /= 0) out = s(1:l-2) 1234 ELSE; i=i-1 1235 IF(s(i-1:i-1)=='-' .AND. INDEX(known_phases,s(i:i)) /= 0) out = s(1:i-2)//s(i+1:l) 1236 END IF 1182 1237 END FUNCTION delPhase 1183 1238 !------------------------------------------------------------------------------------------------------------------------------ … … 1185 1240 CHARACTER(LEN=*), INTENT(IN) :: s 1186 1241 CHARACTER(LEN=1), INTENT(IN) :: pha 1187 IF(INDEX(s,'_')==0) THEN; out = TRIM(s)//'-'//pha; RETURN; END IF 1188 out = TRIM(strHead(s,'_'))//'-'//pha//TRIM(strTail(s,'_')) 1242 INTEGER :: l, i 1243 out = s 1244 IF(s == '') RETURN 1245 i = INDEX(s, '_'); l = LEN_TRIM(s) 1246 IF(i == 0) out = TRIM(s)//'-'//pha 1247 IF(i /= 0) out = s(1:i-1)//'-'//pha//'_'//s(i+1:l) 1189 1248 END FUNCTION addPhase_1 1190 1249 !------------------------------------------------------------------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.
