new version of TecsServer and conversion utility M.Z.
This commit is contained in:
cvs
247
tecs/str.f
247
tecs/str.f
@@ -129,3 +129,250 @@
|
||||
pos=0
|
||||
end
|
||||
|
||||
!!
|
||||
subroutine STR_SPLIT(STR, DELIM, START, ENDE) !!
|
||||
!!
|
||||
!! split string into sequences separated by DELIM
|
||||
!! for the first sequence set ENDE=0 and START=0 (or START=n for other start position n+1)
|
||||
!! result: end of list: ENDE=-1
|
||||
!! empty sequence: START=ENDE+1
|
||||
!! normal sequence: STR(START:ENDE) without delimiter
|
||||
!!
|
||||
!! if ENDE has not a legal value, nothing happens
|
||||
|
||||
character STR*(*), DELIM*(*) !! (in) string, delimiter
|
||||
integer START, ENDE !! (in/out) start/end position
|
||||
|
||||
integer i
|
||||
|
||||
if (ende .lt. 0 .or. ende .ge. len(str) .or. start .lt. 0) then
|
||||
ende=-1
|
||||
RETURN
|
||||
endif
|
||||
if (ende .ne. 0) start=ende+len(delim)
|
||||
if (start .ge. len(str)) then
|
||||
if (start .gt. len(str)) then
|
||||
ende=-1
|
||||
RETURN
|
||||
endif
|
||||
i=0
|
||||
else
|
||||
i=index(str(start+1:), delim)
|
||||
endif
|
||||
if (i .eq. 0) then
|
||||
ende=len(str)
|
||||
else
|
||||
ende=start+i-1
|
||||
endif
|
||||
start=start+1
|
||||
end
|
||||
|
||||
!!
|
||||
subroutine STR_GET_ELEM(STR, POS, ELEM) !!
|
||||
!!
|
||||
!! reads next element ELEM from string STR(POS:). Elements are separated by
|
||||
!! spaces combined with one control-char (assume tab) or one comma.
|
||||
!! return ' ' when STR(POS:) contains only whitespace or when pos is to high
|
||||
!!
|
||||
character STR*(*) !! (in) input string
|
||||
character ELEM*(*) !! (out) element read
|
||||
integer POS !! (in/out) read position
|
||||
|
||||
integer start
|
||||
|
||||
|
||||
1 if (pos .gt. len(str)) then
|
||||
elem=' '
|
||||
RETURN
|
||||
endif
|
||||
if (str(pos:pos) .eq. ' ') then
|
||||
pos=pos+1
|
||||
goto 1
|
||||
endif
|
||||
start=pos
|
||||
2 if (str(pos:pos) .gt. ' ' .and. str(pos:pos) .ne. ',') then
|
||||
pos=pos+1
|
||||
if (pos .le. len(str)) then
|
||||
goto 2
|
||||
endif
|
||||
pos=pos-1
|
||||
endif
|
||||
if (str(pos:pos) .eq. ',' .or. str(pos:pos) .lt. ' ') then
|
||||
if (start .eq. pos) then
|
||||
elem=str(start:pos)
|
||||
else
|
||||
elem=str(start:pos-1)
|
||||
endif
|
||||
pos=pos+1
|
||||
RETURN
|
||||
endif
|
||||
elem=str(start:pos-1)
|
||||
if (str(pos:) .eq. ' ') RETURN
|
||||
3 if (str(pos:pos) .eq. ' ') then
|
||||
pos=pos+1
|
||||
if (pos .gt. len(str)) stop 'STR_GET_ELEM: assertion failed'
|
||||
goto 3
|
||||
endif
|
||||
if (str(pos:pos) .eq. ',' .or. str(pos:pos) .lt. ' ') then
|
||||
pos=pos+1
|
||||
endif
|
||||
end
|
||||
|
||||
!!
|
||||
integer function STR_FIND_ELEM(STR, ELEM) !!
|
||||
!!
|
||||
!! find column index of element ELEM (case insensitive)
|
||||
!! only the first 64 chars of each element are checked
|
||||
!! 0 is returned when not found
|
||||
!!
|
||||
character STR*(*), ELEM*(*)
|
||||
character ups*64, upe*64
|
||||
integer pos, idx
|
||||
|
||||
pos=1
|
||||
call str_upcase(upe, elem)
|
||||
idx=0
|
||||
|
||||
call str_get_elem(str, pos, ups)
|
||||
do while (ups .ne. ' ')
|
||||
idx=idx+1
|
||||
call str_upcase(ups, ups)
|
||||
if (ups .eq. upe) then
|
||||
str_find_elem=idx
|
||||
RETURN
|
||||
endif
|
||||
call str_get_elem(str, pos, ups)
|
||||
enddo
|
||||
str_find_elem=0
|
||||
RETURN
|
||||
end
|
||||
|
||||
!!
|
||||
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 STR_CRC(CRC,BUF) !!
|
||||
!!
|
||||
!! Computes a 16-bit Cyclic Redundancy Check for an character string BUF.
|
||||
!! Before the first call CRC should be intitalized (i.e. to 0) -
|
||||
!! between subsequent call it should left 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 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
|
||||
|
||||
|
||||
Reference in New Issue
Block a user