Changeset 3985 for LMDZ6/branches/LMDZ-tracers/libf/misc
- Timestamp:
- Sep 22, 2021, 6:11:35 PM (3 years ago)
- Location:
- LMDZ6/branches/LMDZ-tracers/libf/misc
- Files:
-
- 2 edited
-
readTracFiles_mod.f90 (modified) (4 diffs)
-
strings_mod.F90 (modified) (13 diffs)
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/branches/LMDZ-tracers/libf/misc/readTracFiles_mod.f90
r3957 r3985 106 106 107 107 !--- TELLS WHAT WAS IS ABOUT TO BE USED 108 IF( test(fmsg(fType==0, 'No adequate tracers description file(s) found ; default values will be used'), lerr)) RETURN108 IF( fmsg(fType==0, 'No adequate tracers description file(s) found ; default values will be used')) RETURN 109 109 CALL msg(fType==1, 'Trying to read old-style tracers description file "traceur.def"') 110 110 CALL msg(fType==2, 'Trying to read the new style multi-sections tracers description file "tracer.def"') … … 860 860 !--- REDUCE THE EXPRESSIONS TO OBTAIN SCALARS AND TRANSFER THEM TO THE "isot" ISOTOPES DESCRIPTORS VECTOR 861 861 DO it = 1, SIZE(dBase(idb)%trac) 862 is = strIdx(isot(iis)%keys(:)%name, dBase(idb)%trac(it)%name) !--- Index of the "isot(iis)%keys(:)%name" tracer named "t%name" 862 t => dBase(idb)%trac(it) 863 is = strIdx(isot(iis)%keys(:)%name, t%name) !--- Index in "isot(iis)%keys(:)%name" of isotope "t%name" 863 864 IF(is == 0) CYCLE 864 t => dBase(idb)%trac(it)865 865 liso = reduceExpr(t%keys%val, vals) !--- Reduce expressions (for substituted variables) 866 isot(iis)%keys(is)%key = PACK(t%keys%key, MASK=liso) 867 isot(iis)%keys(is)%val = PACK( vals, MASK=liso) 866 IF(test(ANY(liso), lerr)) RETURN !--- Some non-numerical elements were found 867 isot(iis)%keys(is)%key = PACK(t%keys%key, MASK=.NOT.liso) 868 isot(iis)%keys(is)%val = PACK( vals, MASK=.NOT.liso) 868 869 END DO 869 870 … … 1228 1229 ELEMENTAL CHARACTER(LEN=256) FUNCTION delPhase(s) RESULT(out) 1229 1230 CHARACTER(LEN=*), INTENT(IN) :: s 1230 INTEGER :: l, i 1231 INTEGER :: l, i, ix 1231 1232 out = s 1232 IF(s == '') RETURN 1233 i = INDEX(s, '_'); l = LEN_TRIM(s) 1234 IF(i == 0) THEN 1235 IF(s(l-1:l-1)==phases_sep .AND. INDEX(known_phases,s(l:l)) /= 0) out = s(1:l-2) 1236 ELSE; i=i-1 1237 IF(s(i-1:i-1)==phases_sep .AND. INDEX(known_phases,s(i:i)) /= 0) out = s(1:i-2)//s(i+1:l) 1233 IF(s == '') RETURN !--- Empty string: nothing to do 1234 !--- Index of found phase in "known_phases" 1235 ix = MAXLOC( [(i, i=1,nphases)], MASK=[( INDEX(s, phases_sep//known_phases(i:i))/=0, i=1, nphases)], DIM=1 ) 1236 IF(ix == 0) RETURN !--- No phase pattern found 1237 i = INDEX(s, phases_sep//known_phases(ix:ix)) !--- Index of <sep><pha> pattern in "str" 1238 l = LEN_TRIM(s) 1239 IF(i == l-1) THEN !--- <var><sep><pha> => return <var> 1240 out = s(1:l-2) 1241 ELSE IF(s(i+2:i+2) == '_') THEN !--- <var><sep><pha>_<tag> => return <var>_<tag> 1242 out = s(1:i-1)//s(i+2:l) 1238 1243 END IF 1239 1244 END FUNCTION delPhase … … 1244 1249 INTEGER :: l, i 1245 1250 out = s 1246 IF(s == '') RETURN 1247 i = INDEX(s, '_'); l = LEN_TRIM(s) 1248 IF(i == 0) out = TRIM(s)//phases_sep//pha 1249 IF(i /= 0) out = s(1:i-1)//phases_sep//pha//'_'//s(i+1:l) 1251 IF(s == '') RETURN !--- Empty string: nothing to do 1252 i = INDEX(s, '_') !--- /=0 for <var>_<tag> tracers names 1253 l = LEN_TRIM(s) 1254 IF(i == 0) out = TRIM(s)//phases_sep//pha !--- <var> => return <var><sep><pha> 1255 IF(i /= 0) out = s(1:i-1)//phases_sep//pha//'_'//s(i+1:l) !--- <var>_<tag> => return <var><sep><pha>_<tag> 1250 1256 END FUNCTION addPhase_1 1251 1257 !------------------------------------------------------------------------------------------------------------------------------ -
LMDZ6/branches/LMDZ-tracers/libf/misc/strings_mod.F90
r3957 r3985 187 187 !============================================================================================================================== 188 188 !=== Extract the substring in front of the last (first if lFirst==TRUE) occurrence of separator "sep" in "str" ================ 189 !=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect: ================ 190 !=== * strHead(..,.FALSE.) = 'a' ${str%%$sep*} ================ 191 !=== * strHead(..,.TRUE.) = 'a_b' ${str%$sep*} ================ 189 192 !============================================================================================================================== 190 193 CHARACTER(LEN=256) FUNCTION strHead_1(str,sep,lFirst) RESULT(out) … … 215 218 out = [(strHead_1(str(k),lFirst=.NOT.lf), k=1, SIZE(str))] 216 219 END IF 217 218 220 END FUNCTION strHead_m 219 221 !============================================================================================================================== 220 !=== Extract the substring following the last (first if lFirst==TRUE) occurrence of separator "sep" in "str" ================== 222 !=== Extract the substring following the last (first if lFirst==TRUE) occurrence of separator "sep" in "str" ================ 223 !=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect: ================ 224 !=== * strHead(..,.FALSE.) = 'b_c' ${str#*$sep} ================ 225 !=== * strHead(..,.TRUE.) = 'c' ${str##*$sep} ================ 221 226 !============================================================================================================================== 222 227 CHARACTER(LEN=256) FUNCTION strTail_1(str,sep,lFirst) RESULT(out) … … 430 435 LOGICAL, OPTIONAL, INTENT(IN) :: lSc !--- Care about nbs with front sign or in scient. notation 431 436 437 INTEGER :: idx0 !--- Used to display an identified non-numeric string 432 438 INTEGER, ALLOCATABLE :: ii(:) 433 439 LOGICAL :: ll, ls … … 435 441 ! modname = 'strIdx' 436 442 lerr = .FALSE. 437 idx = strIdx1(rawList, del, ibeg, idel) 438 IF(.NOT.PRESENT(lSc)) RETURN !--- No need to check exceptions for numbers => finished 439 IF(.NOT. lSc ) RETURN !--- No need to check exceptions for numbers => finished 443 idx = strIdx1(rawList, del, ibeg, idel) !--- del(idel) appears in "rawList" at position idx 444 IF(.NOT.PRESENT(lSc)) RETURN !--- No need to check exceptions for numbers => finished 445 IF(.NOT. lSc ) RETURN !--- No need to check exceptions for numbers => finished 446 IF(idx == 0) THEN !--- No element of "del" in "rawList": 447 lerr = .NOT.is_numeric(rawList(ibeg:)) !--- String must be a number 448 IF(lerr) idx = LEN_TRIM(rawList); RETURN !--- Update idx => rawList(ibeg:idx-1) is the whole string 449 END IF 450 idx0 = idx 451 IF(test(idx==1.AND.INDEX('+-',del(idel))/=0, lerr)) RETURN !--- Front separator different from +/-: error 452 IF(idx/=1.AND.is_numeric(rawList(ibeg:idx-1))) RETURN !--- The input string tail is a valid number 453 idx = strIdx1(rawList, del, idx+1, idel) !--- => TO THE NEXT DELIMITER 440 454 IF(idx == 0) THEN 441 lerr = .NOT.is_numeric(rawList(ibeg:)); RETURN !--- No separator detected: string must be a number 442 END IF 443 IF(test(idx==1.AND.INDEX('+-',del(idel))/=0, lerr)) RETURN !--- Front separator different from +/-: error 444 IF(is_numeric(rawList(ibeg:idx-1))) RETURN !--- The input string tail is a valid number 445 idx = strIdx1(rawList, del, idx+1, idel) !--- => TO THE NEXT DELIMITER 455 lerr = .NOT.is_numeric(rawList(ibeg:)) !--- No delimiter detected: string must be a number 456 IF(lerr) idx = idx0; RETURN 457 END IF 458 idx0 = idx 459 IF(is_numeric(rawList(ibeg:idx-1))) RETURN !--- The input string tail is a valid number 460 IF(test( INDEX('eE',rawList(idx-1:idx-1)) /= 0 & !--- Sole possible exception: scientific notation: E+/- 461 .OR. INDEX('+-',del(idel)) /=0, lerr)) RETURN 462 idx = strIdx1(rawList, del, idx+1, idel) !--- => TO THE NEXT DELIMITER 446 463 IF(idx == 0) THEN 447 lerr = .NOT.is_numeric(rawList(ibeg:)); RETURN !--- No separator detected: string must be a number 448 END IF 449 IF(is_numeric(rawList(ibeg:idx-1))) RETURN !--- The input string tail is a valid number 450 IF(test( INDEX('eE',rawList(idx-1:idx-1)) /= 0 & !--- Sole possible exception: scientific notation: E+/- 451 .OR. INDEX('+-',del(idel)) /=0, lerr)) RETURN 452 idx = strIdx1(rawList, del, idx+1, idel) !--- => TO THE NEXT DELIMITER 453 IF(idx == 0) THEN 454 lerr = .NOT.is_numeric(rawList(ibeg:)); RETURN !--- No separator detected: string must be a number 464 lerr = .NOT.is_numeric(rawList(ibeg:)) !--- No separator detected: string must be a number 465 IF(lerr) idx = idx0; RETURN 455 466 END IF 456 467 lerr = .NOT.is_numeric(rawList(ibeg:idx-1)) 457 458 468 CONTAINS 459 469 … … 538 548 DO 539 549 lerr = strIdx_prv(r, delimiter, ib, ie, jd, ll) 550 IF(fmsg(lerr,'"'//TRIM(r(ib:ie-1))//'" is not numeric')) RETURN 540 551 IF(jd == 0) EXIT 541 IF(fmsg(lerr,'"'//TRIM(r(ib:ie-1))//'" is not numeric')) RETURN542 552 ib = ie + LEN(delimiter(jd)) 543 553 DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO !--- Skip spaces before next chain … … 1117 1127 !=== Reduce an algebrical expression (basic operations and parenthesis) to a single number (string format) ==================== 1118 1128 !============================================================================================================================== 1119 LOGICAL FUNCTION reduceExpr_1(str, val) RESULT( out)1129 LOGICAL FUNCTION reduceExpr_1(str, val) RESULT(lerr) 1120 1130 CHARACTER(LEN=*), INTENT(IN) :: str 1121 1131 CHARACTER(LEN=256), INTENT(OUT) :: val … … 1133 1143 ll = strCount(s,'(',nl) 1134 1144 ll = strCount(s,')',nn) 1135 out = nl == nn1136 IF(fmsg( .NOT.out, 'Mismatching number of opening and closing parenthesis: '//TRIM(s))) RETURN1145 lerr = nl /= nn 1146 IF(fmsg(lerr, 'Mismatching number of opening and closing parenthesis: '//TRIM(s))) RETURN 1137 1147 nl = 2*nl-1 1138 1148 … … 1152 1162 DO WHILE(nl > 1) 1153 1163 i = 1; DO WHILE(ip(i) /= 1 .OR. ip(i+1) /= 2); i = i + 1; END DO !IF(i > SIZE(ip)+1) EXIT;END DO 1154 out = reduceExpr_basic(vl(i+1), v); IF(.NOT. out) RETURN1164 IF(test(reduceExpr_basic(vl(i+1), v), lerr)) RETURN 1155 1165 v = TRIM(vl(i))//TRIM(v); IF(i+2<=nl) v=TRIM(v)//TRIM(vl(i+2)) 1156 1166 vv = v//REPEAT(' ',768) … … 1160 1170 nl = SIZE(vl) 1161 1171 END DO 1162 out= reduceExpr_basic(vl(1), val)1172 lerr = reduceExpr_basic(vl(1), val) 1163 1173 END FUNCTION reduceExpr_1 1164 1174 … … 1167 1177 !=== Reduce a simple algebrical expression (basic operations, no parenthesis) to a single number (string format) ============== 1168 1178 !============================================================================================================================== 1169 LOGICAL FUNCTION reduceExpr_basic(str, val) RESULT( out)1179 LOGICAL FUNCTION reduceExpr_basic(str, val) RESULT(lerr) 1170 1180 CHARACTER(LEN=*), INTENT(IN) :: str 1171 1181 CHARACTER(LEN=*), INTENT(OUT) :: val … … 1178 1188 DOUBLE PRECISION :: v, vm, vp 1179 1189 INTEGER :: i, ni, io 1180 LOGICAL :: ll1181 1190 1182 1191 ! modname = 'reduceExpr_basic' 1183 out = .TRUE.1192 lerr = .FALSE. 1184 1193 IF(is_numeric(str)) THEN; val=TRIM(str); RETURN; END IF 1185 1194 op = ['^','/','*','+','-'] !--- List of recognized operations 1186 1195 s = str 1187 ll = strParse_m(s, op, ky, .TRUE., id = id)!--- Parse the values1196 IF(test(strParse_m(s, op, ky, .TRUE., id = id), lerr)) RETURN !--- Parse the values 1188 1197 vl = str2dble(ky) !--- Conversion to doubles 1189 out = ALL(vl <HUGE(1.d0))1190 IF(fmsg( .NOT.out,'Some values are non-numeric in: '//TRIM(s))) RETURN!--- Non-numerical values found1198 lerr = ANY(vl >= HUGE(1.d0)) 1199 IF(fmsg(lerr,'Some values are non-numeric in: '//TRIM(s))) RETURN !--- Non-numerical values found 1191 1200 DO io = 1, SIZE(op) !--- Loop on known operators (order matters !) 1192 1201 DO i = SIZE(id), 1, -1 !--- Loop on found operators … … 1211 1220 1212 1221 !============================================================================================================================== 1213 FUNCTION reduceExpr_m(str, val) RESULT( out)1214 LOGICAL, ALLOCATABLE :: out(:)1222 FUNCTION reduceExpr_m(str, val) RESULT(lerr) 1223 LOGICAL, ALLOCATABLE :: lerr(:) 1215 1224 CHARACTER(LEN=*), INTENT(IN) :: str(:) 1216 1225 CHARACTER(LEN=256), ALLOCATABLE, INTENT(OUT) :: val(:) 1217 1226 INTEGER :: i 1218 ALLOCATE( out(SIZE(str)),val(SIZE(str)))1219 out(:) = [(reduceExpr_1(str(i), val(i)), i=1, SIZE(str))]1227 ALLOCATE(lerr(SIZE(str)),val(SIZE(str))) 1228 lerr(:) = [(reduceExpr_1(str(i), val(i)), i=1, SIZE(str))] 1220 1229 END FUNCTION reduceExpr_m 1221 1230 !============================================================================================================================== … … 1230 1239 INTEGER :: e 1231 1240 CHARACTER(LEN=12) :: fmt 1241 IF(TRIM(str) == '') THEN; out = .FALSE.; RETURN; END IF 1232 1242 WRITE(fmt,'("(f",i0,".0)")') LEN_TRIM(str) 1233 1243 READ(str,fmt,IOSTAT=e) x
Note: See TracChangeset
for help on using the changeset viewer.
