241 lines
5.4 KiB
Fortran
241 lines
5.4 KiB
Fortran
!!------------------------------------------------------------------------------
|
|
!!
|
|
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
|
|
real xlog
|
|
|
|
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
|
|
xlog=log10(abs(x))
|
|
exponent=int(xlog+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
|
|
if (abs(f0) .gt. 99999) goto 19
|
|
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
|
|
goto 18
|
|
endif
|
|
|
|
! F-Format is better
|
|
13 p=bufmax-fdig
|
|
if (fix .eq. 0 .and. trc .ge. 2) p=p-1 ! Decimal point not needed if fix=0
|
|
|
|
18 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
|
|
|
|
!!------------------------------------------------------------------------------
|
|
!!
|
|
real function CVT_RATIO(STR, FAILUREVALUE) !!
|
|
!! ==========================================
|
|
!!
|
|
!! decode a ratio (value1/value) to a real number
|
|
!!
|
|
character STR*(*) !! string to convert
|
|
real FAILUREVALUE !! value to return on failure
|
|
|
|
integer i
|
|
real r1,r2
|
|
|
|
i=index(str, '/')
|
|
if (i .eq. 0) then
|
|
read(str,*,err=999,end=999) cvt_ratio
|
|
return
|
|
else
|
|
if (i .eq. 1 .or. i .eq. len(str)) goto 999
|
|
read(str(1:i),*,err=999,end=999) r1
|
|
read(str(i+1:),*,err=999,end=999) r2
|
|
cvt_ratio = r1/r2
|
|
return
|
|
endif
|
|
999 cvt_ratio=failurevalue
|
|
end
|