!!------------------------------------------------------------------------------ !! 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 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