linse/sicspsi
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added calibration table and conversion tool M.Z.

Browse Source
This commit is contained in:
cvs
2003-08-27 13:00:02 +00:00
parent b9517673c8
commit e70aa6e6b7
54 changed files with 7595 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

492
tecs/strings.f90 Normal file
View File

@@ -0,0 +1,492 @@
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