updated conversion utilities M.Z.

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
+

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<WIDTH>.<FIXLEN>.
+!! 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