diff --git a/tecs/conv.inc b/tecs/conv.inc new file mode 100644 index 0000000..3febb0d --- /dev/null +++ b/tecs/conv.inc @@ -0,0 +1,11 @@ + integer ncolumn + parameter (ncolumn=3) + integer lun,pos,nlist,errstat,lf,lp + common /convcom/lun,pos,nlist,errstat,lf,lp + logical verbose + common /convcom/verbose + character*128 file, path + common /convcom/file, path + character*128 list(1000) + common /convcom/list + diff --git a/tecs/cvt.f b/tecs/cvt.f new file mode 100644 index 0000000..219730b --- /dev/null +++ b/tecs/cvt.f @@ -0,0 +1,208 @@ +!!------------------------------------------------------------------------------ +!! + subroutine CVT_REAL_STR(RESULT, RESLEN, X, !! + 1 WIDTH, FIXLEN, DIGITS, TRUNC) !! +!! ===================================================== +!! +!! Convert X to RESULT (subroutine version) +!! +!! The number is converted using Fortran format F.. +!! If the number is too large or the number of significant digits is to +!! low, the number digits after the decimal point is changed or, if this is +!! is not possible, an E-format is choosen. If WIDTH is lower than 6, the +!! result length will be larger in some cases. +!! +!! Default format (WIDTH < 0, FIXLEN < -1, DIGITS < 0) +!! + implicit none + +!! Arguments + character*(*) RESULT !! + integer RESLEN !! length of result + real X !! number to be converted + integer WIDTH !! minimum width + integer FIXLEN !! minimum digits after comma + integer DIGITS !! minimum significant digits + integer TRUNC !! TRUNC=1,3: omit trailing zeros + !! TRUNC=0,1: decimal point always shown + + integer bufmax + parameter (bufmax=32) + integer wid, fix, dig, trc + character*(bufmax) fixbuf, expbuf ! internal buffers + integer exponent + real mantissa + integer f0, fl, e0, el ! start and end of used buffer F/E + integer fdig, edig ! digits after decimal point F/E format + integer overhd ! overhead + integer p ! position of decimal point + integer digf ! number of digits-1 shown (F-Format) + integer le, l + character*8 rfmt + + trc=trunc + if (mod(trc,2) .eq. 1) then ! defaults + wid=1 + fix=0 + dig=4 + if (width .ge. 0) wid=width + else + wid=min(8,len(result)) + if (width .ge. 0) wid=width + fix=max(0,wid/2-1) + dig=1 + endif + if (fixlen .ge. 0) fix=fixlen + if (digits .ge. 0) dig=digits + + wid=min(bufmax, wid, len(result)) + dig=min(bufmax, dig) + + if (x .eq. 0) then + exponent=0 + mantissa=0 + else + exponent=int(log10(abs(x))+100)-100 + mantissa=x/10.0**exponent + endif + + + edig=min(max(wid-4,dig-1),len(result)-4) + fdig=min(max(fix,dig-1-exponent),len(result)-1) + +! F-Format + +11 f0=0 + fl=bufmax+1 ! in case of write error + digf=-1 + if (fdig .lt. -exponent) goto 14 + write(rfmt, '(''(F'',I2.2,''.'',I2.2,'')'')') bufmax, fdig + write(fixbuf, rfmt, err=14) x + +! reduce + + f0=bufmax-fdig + if (exponent .gt. 0) f0=f0-exponent + do while(f0 .gt. 0 .and. fixbuf(f0:f0) .ne. ' ') + f0=f0-1 + enddo + fl=bufmax-1 + do while(fixbuf(fl+1:fl+1) .eq. ' ') + fl=fl-1 + enddo + overhd=fl+1-f0-len(result) + do while (fixbuf(fl+1:fl+1) .eq. '0' + 1 .and. (overhd .gt. 0 .or. mod(trc,2) .eq. 1)) + fl=fl-1 + overhd=overhd-1 + enddo + if (fixbuf(fl+1:fl+1) .eq. '.' .and. trc .ge. 2) then + overhd=overhd-1 + else + fl=fl+1 + endif + if (overhd .gt. 0) then +12 if (fdig .ge. overhd) then + fdig=fdig-overhd + goto 11 ! try again with less digits + endif + fl=bufmax+1 + endif + digf=fdig+exponent + +! E-Format mantissa + +14 if (x .eq. 0 .or. edig .lt. 0) goto 13 + +15 write(rfmt, '(''(F'',I2.2,''.'',I2.2,'')'')') bufmax-4, edig + write(expbuf(1:bufmax-4), rfmt, err=19) mantissa + + if (exponent .gt. -10) then + if (exponent .lt. 10 .and. exponent .ge. 0) then + le=2 + else + le=3 + endif + else + le=4 + endif + +! reduce + + e0=bufmax-6-edig + if (e0 .gt. 0) then + if (expbuf(e0:e0) .eq. '1') then ! 9.9 was rounded to 10 + exponent=exponent+1 + mantissa=mantissa/10.0 + goto 15 + endif + if (expbuf(e0:e0) .eq. '-') e0=e0-1 + endif + + el=bufmax-5 + do while(expbuf(el+1:el+1) .eq. ' ') + el=el-1 + enddo + overhd=el+le+1-e0-len(result) + do while (expbuf(el+1:el+1) .eq. '0' .and. + 1 (overhd .gt. 0 .or. mod(trc,2) .ne. 0)) + el=el-1 + overhd=overhd-1 + enddo + if (expbuf(el+1:el+1) .eq. '.' .and. trc .ge. 2) then + overhd=overhd-1 + else + el=el+1 + endif + + if (overhd .gt. 0) then + if (edig .ge. overhd) then + edig=edig-overhd + goto 14 ! try again with less digits + endif + el=bufmax+1 + else + write(rfmt, '(''(A,I'',I2.2,'')'')') le-1 + write(expbuf(el+1:el+le), rfmt) 'E',exponent + el=el+le + endif + + +! Compare + + l=fl-f0 + if (l .gt. wid .and. + 1 (edig .gt. digf .or. + 1 edig .eq. digf .and. l .gt. el-e0 .or. + 1 l .gt. len(result))) then ! E-format is better + fixbuf=expbuf + f0=e0 + fl=el + p=bufmax-4-edig + else + p=bufmax-fdig + if (fix .eq. 0 .and. trc .ge. 2) p=p-1 ! Decimal point not needed if fix=0 + endif + +13 l=fl-f0 + if (l .gt. len(result)) then + goto 19 + elseif (p-f0 .gt. wid-fix .or. l .ge. wid) then ! Left just + result=fixbuf(f0+1:fl) + elseif (fl-p .gt. fix) then ! Right just + result=fixbuf(fl-wid+1:fl) + l=wid + else ! Decimal just + result=fixbuf(p+fix-wid+1:fl) + l=fl+wid-p-fix + endif + reslen=min(l, len(result)) + return + +19 result='******' + reslen=len(result) + end + + subroutine cvt_bintim + stop 'CVT_BINTIM: obsolete' + end