493 lines
12 KiB
Fortran
493 lines
12 KiB
Fortran
MODULE Strings !!
|
|
|
|
!! string handling
|
|
|
|
CONTAINS
|
|
|
|
!!
|
|
subroutine STR_TRIM(RETSTR, STR, RETLEN) !!
|
|
!!
|
|
!! if RETSTR=STR then RETSTR is not touched
|
|
!!
|
|
character*(*) STR, RETSTR !! in,out
|
|
integer RETLEN !! out
|
|
integer i
|
|
|
|
i=len(str)
|
|
if (str(1:1) .gt. ' ') then
|
|
10 if (str(i:i) .le. ' ') then
|
|
i=i-1
|
|
goto 10
|
|
endif
|
|
else
|
|
20 if (str(i:i) .le. ' ') then
|
|
if (i .gt. 1) then
|
|
i=i-1
|
|
goto 20
|
|
endif
|
|
endif
|
|
endif
|
|
retlen=i
|
|
if (retstr .ne. str) then ! avoid copy to retstr if equal
|
|
retstr=str(1:i)
|
|
endif
|
|
end subroutine
|
|
|
|
!!
|
|
subroutine STR_UPCASE(RETSTR, STR) !!
|
|
!!
|
|
character STR*(*), RETSTR*(*) !! in,out
|
|
integer i, ch
|
|
|
|
retstr=str
|
|
do i=1,len(retstr)
|
|
ch=ichar(retstr(i:i))
|
|
if (ch .ge. ichar('a') .and. ch .le. ichar('z')) then
|
|
retstr(i:i)=char(ch-(ichar('a')-ichar('A')))
|
|
endif
|
|
enddo
|
|
end subroutine
|
|
|
|
!!
|
|
subroutine STR_LOWCASE(RETSTR, STR) !!
|
|
!!
|
|
character STR*(*), RETSTR*(*) !! in,out
|
|
integer i, ch
|
|
|
|
retstr=str
|
|
do i=1,len(retstr)
|
|
ch=ichar(retstr(i:i))
|
|
if (ch .ge. ichar('A') .and. ch .le. ichar('Z')) then
|
|
retstr(i:i)=char(ch+(ichar('a')-ichar('A')))
|
|
endif
|
|
enddo
|
|
end subroutine
|
|
|
|
!!
|
|
subroutine STR_APPEND(STR, LENGTH, ADD) !!
|
|
!!
|
|
!! append ADD to STR(1:LENGTH)
|
|
!! when STR too short, it is truncated
|
|
!!
|
|
character*(*) str !! (in/out)
|
|
character*(*) add !! (in)
|
|
integer length !! (in/out)
|
|
|
|
if (len(add)+length .gt. len(str)) then
|
|
if (length .lt. len(str)) then
|
|
str(length+1:)=add
|
|
length=len(str)
|
|
endif
|
|
else
|
|
str(length+1:length+len(add))=add
|
|
length=length+len(add)
|
|
endif
|
|
end subroutine
|
|
|
|
!!
|
|
integer function STR_CMP(str1, str2) !!
|
|
!!
|
|
!! if strings are equal: return 0
|
|
!! else return position of first different character
|
|
!!
|
|
character STR1*(*), STR2*(*) !! (in) strings to comapre
|
|
|
|
integer i
|
|
|
|
do i=0,min(len(str1),len(str2))-1
|
|
if (str1(i+1:i+1) .ne. str2(i+1:i+1)) then
|
|
str_cmp=i+1
|
|
return
|
|
endif
|
|
enddo
|
|
do i=len(str1),len(str2)-1
|
|
if (str2(i+1:i+1) .ne. ' ') then
|
|
str_cmp=i+1
|
|
return
|
|
endif
|
|
enddo
|
|
do i=len(str2),len(str1)-1
|
|
if (str1(i+1:i+1) .ne. ' ') then
|
|
str_cmp=i+1
|
|
return
|
|
endif
|
|
enddo
|
|
str_cmp=0
|
|
return
|
|
end function
|
|
|
|
!!
|
|
subroutine STR_FIRST_NONBLANK(STR, POS) !!
|
|
!!
|
|
!! Arguments:
|
|
character*(*) STR !! in
|
|
integer POS !! out
|
|
integer i
|
|
|
|
do i=1,len(str)
|
|
if (str(i:i) .gt. ' ') then
|
|
pos=i
|
|
return
|
|
endif
|
|
enddo
|
|
pos=0
|
|
end subroutine
|
|
|
|
!!
|
|
subroutine STR_SUBSTITUTE(RESULT, STR, OLD, NEW) !!
|
|
!!
|
|
!! replace all occurences of substring OLD in STR by NEW
|
|
!! special case: if NEW=CHAR(0) then a null length string is replaced
|
|
!!
|
|
character RESULT*(*), STR*(*) !! (out), (in) strings (must either be equal or not overlap)
|
|
character OLD*(*), NEW*(*) !! substrings (in)
|
|
|
|
integer i,j,k
|
|
|
|
i=0
|
|
j=index(str, old)-1
|
|
if (len(new) .eq. 1 .and. new(1:1) .eq. char(0)) then
|
|
k=0
|
|
do while (j .ge. 0)
|
|
if (j .gt. 0) result(k+1:k+j)=str(i+1:i+j)
|
|
i=i+j+len(old)
|
|
k=k+j
|
|
if (i .ge. len(str)) then
|
|
if (k .lt. len(result)) result(k+1:)=' '
|
|
RETURN
|
|
endif
|
|
j=index(str(i+1:), old)-1
|
|
enddo
|
|
if (k .lt. len(result)) result(k+1:)=str(i+1:)
|
|
elseif (len(old) .ge. len(new)) then
|
|
k=0
|
|
do while (j .ge. 0)
|
|
if (j .gt. 0) result(k+1:k+j)=str(i+1:i+j)
|
|
i=i+j+len(old)
|
|
k=k+j
|
|
result(k+1:k+len(new))=new
|
|
k=k+len(new)
|
|
if (i .ge. len(str)) then
|
|
if (k .lt. len(result)) result(k+1:)=' '
|
|
RETURN
|
|
endif
|
|
j=index(str(i+1:), old)-1
|
|
enddo
|
|
if (k .lt. len(result)) result(k+1:)=str(i+1:)
|
|
else
|
|
result=str
|
|
do while (j .ne. 0)
|
|
i=i+j
|
|
result(i+1:)=new//result(i+len(old)+1:)
|
|
i=i+len(new)
|
|
if (i .ge. len(str)) RETURN
|
|
j=index(str(i+1:), old)-1
|
|
enddo
|
|
endif
|
|
end subroutine
|
|
|
|
!!
|
|
subroutine STR_SPLIT(STR, DELIM, START, END) !!
|
|
!!
|
|
!! split string into sequences separated by DELIM
|
|
!! for the first sequence set END=0 and START=0 (or START=n for other start position n+1)
|
|
!! result: end of list: END=0, START=0
|
|
!! empty sequence: START=END+1
|
|
!! normal sequence: STR(START:END) without delimiter
|
|
!!
|
|
character STR*(*), DELIM*(*) !! (in) string, delimiter
|
|
integer START, END !! (in/out) start/end position
|
|
|
|
integer i
|
|
|
|
if (end .eq. len(str)) then
|
|
start=0
|
|
end=0
|
|
RETURN
|
|
endif
|
|
if (end .ne. 0) start=end+len(delim)
|
|
i=index(str(start+1:), delim)
|
|
if (i .eq. 0) then
|
|
end=len(str)
|
|
else
|
|
end=start+i-1
|
|
endif
|
|
start=start+1
|
|
end subroutine
|
|
|
|
!!
|
|
subroutine STR_FMT_REAL(RESULT, RESLEN, X, WIDTH, FIXLEN, DIGITS, TRUNC) !!
|
|
!!
|
|
!! Convert X to RESULT
|
|
!!
|
|
!! 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)
|
|
!!
|
|
|
|
!! 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
|
|
|
|
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
|
|
|
|
|
|
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(fixbuf, 101, err=14) x
|
|
101 format (F<bufmax>.<fdig>)
|
|
|
|
! 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' .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(expbuf(1:bufmax-4), 102, err=19) mantissa
|
|
102 format (F<bufmax-4>.<edig>)
|
|
|
|
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. (overhd .gt. 0 .or. trc))
|
|
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(expbuf(el+1:el+le), 103) exponent
|
|
103 format('E',I<le-1>)
|
|
el=el+le
|
|
endif
|
|
|
|
|
|
! Compare
|
|
|
|
l=fl-f0
|
|
if (l .gt. wid .and. &
|
|
& (edig .gt. digf .or. &
|
|
& edig .eq. digf .and. l .gt. el-e0 .or. &
|
|
& 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
|
|
|
|
subroutine STR_CRC(CRC,BUF) !!
|
|
!!
|
|
!! Computes a 16-bit Cyclic Redundancy Check for an character string BUF.
|
|
!! In the first call CRC should be intitalized -
|
|
!! between subsequent call it should be untouched.
|
|
|
|
integer CRC !! (in/out) CRC code
|
|
character BUF*(*) !! characters
|
|
|
|
|
|
integer init,ireg,i,j,icrctb(0:255),ichr,ib1,ib2,ib3
|
|
character*1 creg(4)
|
|
save icrctb,init,ib1,ib2,ib3
|
|
equivalence (creg,ireg) ! used to get at the 4 bytes in an integer.
|
|
data init /0/
|
|
|
|
integer crc1, crc2
|
|
|
|
if (init.eq.0) then ! initialize tables?
|
|
init=1
|
|
ireg=256*(256*ichar('3')+ichar('2'))+ichar('1')
|
|
do j=1,4 ! figure out which component of creg addresses which byte of ireg.
|
|
if (creg(j).eq.'1') ib1=j
|
|
if (creg(j).eq.'2') ib2=j
|
|
if (creg(j).eq.'3') ib3=j
|
|
enddo
|
|
do j=0,255 ! create CRCs of all characters.
|
|
ireg=j*256
|
|
|
|
do i=1,8 ! Here is where 8 one-bit shifts, and some XORs with the generator polynomial, are done.
|
|
ichr=ichar(creg(ib2))
|
|
ireg=ireg+ireg
|
|
creg(ib3)=char(0)
|
|
if(ichr.gt.127)ireg=ieor(ireg,4129)
|
|
enddo
|
|
|
|
icrctb(j)=ireg
|
|
enddo
|
|
endif
|
|
ireg=crc
|
|
crc1=ichar(creg(ib1))
|
|
crc2=ichar(creg(ib2))
|
|
|
|
do j=1,len(buf) ! Main loop over the characters
|
|
ireg=icrctb(ieor(ichar(buf(j:j)),crc2))
|
|
crc2=ieor(ichar(creg(ib2)),crc1)
|
|
crc1=ichar(creg(ib1))
|
|
enddo
|
|
creg(ib1)=char(crc1)
|
|
creg(ib2)=char(crc2)
|
|
crc=ireg
|
|
return
|
|
end subroutine
|
|
|
|
!!
|
|
subroutine STR_CRC_COMP(CRC, CHR) !!
|
|
!!
|
|
!! encode CRC (16 bit) as 3 characters in CHR
|
|
!!
|
|
integer CRC !! (in)
|
|
character CHR*3 !! (out)
|
|
|
|
integer n,j
|
|
character*41 cs/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ$+-&_'/
|
|
|
|
if (crc .lt. 0 .or. crc .gt. 65535) stop 'STR_CRC_COMP: illegal CRC'
|
|
n=crc
|
|
j=mod(n,41)
|
|
chr(1:1)=cs(j+1:j+1)
|
|
n=n/41
|
|
j=mod(n,41)
|
|
chr(2:2)=cs(j+1:j+1)
|
|
j=n/41
|
|
chr(3:3)=cs(j+1:j+1)
|
|
end subroutine
|
|
|
|
end module
|