666 lines
16 KiB
Fortran
666 lines
16 KiB
Fortran
program conv
|
|
|
|
use strings
|
|
|
|
integer, parameter :: ncolumn=3
|
|
logical init
|
|
integer lun/0/,pos/0/,nlist/0/,ctx/0/
|
|
integer i,l,lin
|
|
character*128 file, input, list(1000), line
|
|
logical wild
|
|
integer errstat
|
|
|
|
call sys_get_cmdpar(input, l)
|
|
if (input .ne. ' ') then
|
|
i=index(input, '.')
|
|
if (i .ne. 0) input(i:)=' '
|
|
endif
|
|
if (input == ' ') then
|
|
print '(a,$)',' Device(s) (lowercase, separated by space, return for all): '
|
|
read(*,'(a)',end=99) input
|
|
endif
|
|
if (input == 'all') input=' '
|
|
|
|
open(3, file='src/cfg/tecs.cfg', status='old',readonly,iostat=i)
|
|
if (i .ne. 0) then
|
|
print *,'can not open tecs.cfg'
|
|
end if
|
|
|
|
do
|
|
read(3, '(a)', iostat=i) line
|
|
if (i .ne. 0) EXIT
|
|
i=index(line, "'")
|
|
if (i==0) CYCLE
|
|
file=line(i+1:)
|
|
i=index(file, "'")
|
|
if (i<2) CYCLE
|
|
file(i:i)=' '
|
|
if (input .ne. ' ' .and. index(' '//input, ' '//file(1:i)) .eq. 0) CYCLE
|
|
file(i:)='.inp'
|
|
l=i+3
|
|
print *
|
|
open(1,name='src/cfg/'//file(1:l),status='old',readonly,iostat=i)
|
|
if (i .ne. 0) then
|
|
print *,'can not open ',file(1:l)
|
|
print "(x,60('-'))"
|
|
nlist=nlist+1
|
|
list(nlist)='can not open '//file(1:l)
|
|
else
|
|
lin=0
|
|
do
|
|
print "(x,60('-'))"
|
|
call lsc_errinit(1) ! 1=lun
|
|
call lsc_convert_table(lin, file(1:l))
|
|
if (lin<0) EXIT
|
|
enddo
|
|
close(1)
|
|
endif
|
|
enddo
|
|
|
|
print "(x,60('-'))"
|
|
do i=1,nlist
|
|
call str_trim(list(i), list(i), l)
|
|
print *,list(i)(1:l)
|
|
enddo
|
|
|
|
99 continue
|
|
|
|
contains
|
|
|
|
subroutine pack(line, l, x, y, offset, m)
|
|
character line*(*)
|
|
integer l, offset, m
|
|
real x(m), y(m)
|
|
|
|
integer j,p
|
|
|
|
p=0
|
|
do j=1,m
|
|
call str_append(line, p, '#0,')
|
|
call str_fmt_real(line(p+1:), l, 1.0*(offset+j), 1, 0, 6, 3)
|
|
p=p+l
|
|
call str_append(line, p, ':')
|
|
call str_fmt_real(line(p+1:), l, x(j), 1, 0, 6, 3)
|
|
p=p+l
|
|
call str_append(line, p, ',')
|
|
call str_fmt_real(line(p+1:), l, y(j), 1, 0, 6, 3)
|
|
p=p+l
|
|
call str_append(line, p, ';')
|
|
enddo
|
|
line(p:p)=' '
|
|
l=p-1
|
|
end subroutine
|
|
|
|
|
|
subroutine lsc_convert_table(lin, file)
|
|
|
|
implicit none
|
|
|
|
integer lin
|
|
character(len=*) file
|
|
|
|
integer, parameter :: ntypes=12, nvolts=12, namps=12
|
|
integer n
|
|
|
|
real x(200), y(200), ex, ey
|
|
integer i,j,l,p,li,crc,form
|
|
|
|
character name*15, sensor*10, header*64, line*128, old*128, intype*16
|
|
character crcmp*3, filnam*24
|
|
character months*12/'123456789ond'/
|
|
character c40*40/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ$+-&'/
|
|
integer unit, type, excit, irange, coef, iunit, stdcurv
|
|
! codes
|
|
character types(0:ntypes)*12/'Special','Si Diode','GaAlAs Diode' &
|
|
,'Pt250 Ohm','Pt500 Ohm','Pt2500 Ohm','RhFe','C-Glass' &
|
|
,'Cernox','RuOx','Ge','??','TC'/
|
|
integer, parameter :: nunits=3
|
|
character units(nunits)*5/'mV','V','Ohm'/
|
|
integer, parameter :: nexcits=12
|
|
character excits(0:nexcits)*8/'Off','30nA','100nA','300nA','1uA','3uA' &
|
|
,'10uA','30uA','100uA','300uA','1mA','10mV','1mV'/
|
|
integer, parameter :: nforms=5
|
|
character forms(nforms)*6/'ill','ill','lin','log','loglog'/
|
|
|
|
! default values
|
|
integer defu(ntypes)/ 1, 1, 2, 2,2, 2, 2, 2, 2, 2, 3, 1/ ! unit
|
|
integer defe(ntypes)/ 6, 6,10,10,8,10,11,11,11,12, 0, 0/ ! excit
|
|
integer defr(ntypes)/11,12, 8, 9,8, 8, 4, 4, 4, 1, 1, 6/ ! range
|
|
integer defc(ntypes)/ 1, 1, 2, 2,2, 2, 1, 1, 1, 1, 2, 2/ ! coef
|
|
real volts(nvolts)/1E-3,2.5E-3,5E-3,1E-2,2.5E-2,5E-2 &
|
|
,1E-1,2.5E-1,5E-1,1E-0,2.5E-0,5E-0/
|
|
real amps(namps)/3E-8,1E-7,3E-7,1E-6,3E-6,1E-5,3E-5,1E-4,3E-4,1E-3 &
|
|
,3E-8,3E-8/ ! minimal values are for voltage excitation
|
|
integer, parameter :: stdmax=10
|
|
character (len=40) stdhdr(stdmax)/ &
|
|
'DT-470 ,Standard ,2,+475.000E+0,1', &
|
|
'DT-500-D ,Standard ,2,+365.000E+0,1', &
|
|
'DT-500-E1 ,Standard ,2,+330.000E+0,1', &
|
|
'PT-100 ,Standard ,3,+800.000E+0,2', &
|
|
'PT-1000 ,Standard ,3,+800.000E+0,2', &
|
|
'TYPE K ,Standard ,1,+1645.00E+0,2', &
|
|
'TYPE E ,Standard ,1,+1188.50E+0,2', &
|
|
'TYPE T ,Standard ,1,+673.000E+0,2', &
|
|
'CrAuFe.03%,Standard ,1,+500.000E+0,2', &
|
|
'CrAuFe.07%,Standard ,1,+610.000E+0,2'/
|
|
integer stdtype(stdmax)/1,1,1,4,5,12,12,12,12,12/
|
|
|
|
real tlim, range, xmax, ymax, curr, rl
|
|
|
|
real x1,x2,xi,y1,y2,yi,sum,sum1,sum2,mum,mum1,mum2,d,at,at1,at2
|
|
logical eof, first
|
|
|
|
first=.true.
|
|
eof=.false.
|
|
n=0
|
|
name=' '
|
|
sensor=' '
|
|
unit=0
|
|
tlim=0
|
|
type=0
|
|
excit=0
|
|
form=0
|
|
range=-1.0
|
|
stdcurv=0
|
|
1 read(1,'(q,a)',err=97,end=97) l,line
|
|
lin=lin+1
|
|
l=max(1,min(l,len(line)))
|
|
call str_first_nonblank(line, i)
|
|
if (i .eq. 0) goto 1
|
|
if (line(i:i) .eq. '!') goto 1
|
|
first=.false.
|
|
call str_upcase(line(1:l),line(i:l))
|
|
i=index(line(1:l),'!')
|
|
if (i .ne. 0) line=line(1:i-1)
|
|
call str_trim(line(1:l),line(1:l),l)
|
|
if (line(1:4) .ne. 'CURV') then
|
|
i=index(line,'=')
|
|
if (i .eq. 0) then
|
|
call lsc_error(lin, 'missing "="')
|
|
goto 1
|
|
endif
|
|
if (i .eq. l) then
|
|
call lsc_error(lin, 'missing value')
|
|
goto 1
|
|
endif
|
|
call str_first_nonblank(line(i+1:l), j)
|
|
i=i+j
|
|
if (line(1:4) .eq. 'NAME') then
|
|
call str_lowcase(name,line(i:l))
|
|
elseif (line(1:4) .eq. 'SENS') then
|
|
sensor=line(i:l)
|
|
elseif (line(1:4) .eq. 'UNIT') then
|
|
unit=lsc_getno(units, nunits, line(i:l))
|
|
if (unit .le. 0) call lsc_error(lin, 'illegal unit')
|
|
elseif (line(1:4) .eq. 'TLIM') then
|
|
read(line(i:l),*,err=92,end=92) tlim
|
|
elseif (line(1:4) .eq. 'TYPE') then
|
|
type=lsc_getno(types, ntypes, line(i:l))-1
|
|
if (type .lt. 0) call lsc_error(lin, 'illegal type')
|
|
elseif (line(1:4) .eq. 'EXCI') then
|
|
call str_substitute(line(1:8),line(i:l),' ',char(0))
|
|
excit=lsc_getno(excits, nexcits, line(1:8))-1
|
|
if (excit .lt. 0) call lsc_error(lin, 'illegal excitation')
|
|
elseif (line(1:4) .eq. 'RANG') then
|
|
read(line(i:l),*,err=93,end=93) range
|
|
if (range .lt. 0) goto 93
|
|
elseif (line(1:4) .eq. 'FORM') then
|
|
form=lsc_getno(forms, nforms, line(i:l))
|
|
if (form .lt. 3) call lsc_error(lin, 'illegal format')
|
|
else
|
|
call lsc_error(lin, 'unknown parameter name')
|
|
endif
|
|
goto 1
|
|
endif
|
|
if (name .eq. ' ') call lsc_error(lin, 'missing name')
|
|
i=index(line,'=')
|
|
if (i .ne. 0) then
|
|
read(line(i+1:l), *, err=2,end=2) stdcurv
|
|
2 continue
|
|
if (stdcurv<0 .or. stdcurv>stdmax) then
|
|
call lsc_error(lin, 'illegal standard curve no.')
|
|
goto 101
|
|
endif
|
|
if (unit/=0 .or. type/=0 .or. &
|
|
excit/=0 .or. tlim/=0 .or. sensor/=' ') then
|
|
print *,'Warning: all parameters except "name", "range" and "curv" are ignored',char(7)
|
|
errstat=max(errstat,1)
|
|
endif
|
|
line=stdhdr(stdcurv)
|
|
i=index(line, ',')
|
|
if (i .eq. 0) goto 96 ! illegal stdhdr
|
|
j=index(line(i+1:), ',')
|
|
if (j .eq. 0) goto 96 ! illegal stdhdr
|
|
|
|
read(line(i+j+1:), *, err=96, end=96) unit, ymax, coef
|
|
type=stdtype(stdcurv)
|
|
! if (range < 0) then
|
|
! range=stdrange(stdcurv)
|
|
! end if
|
|
xmax=0
|
|
excit=0
|
|
tlim=0
|
|
goto 100
|
|
endif
|
|
if (line(5:) /= ' ') then
|
|
call lsc_error(lin, 'missing "="')
|
|
goto 101
|
|
end if
|
|
! user curve
|
|
if (unit .eq. 0) call lsc_error(lin, 'missing unit')
|
|
if (type .eq. 0) then
|
|
if (excit .le. 0) call lsc_error(lin, 'missing excitation')
|
|
if (range .lt. 0) call lsc_error(lin, 'missing range')
|
|
else
|
|
if (excit .eq. 0) excit=defe(type)
|
|
endif
|
|
3 n=n+1
|
|
read(1,'(a)',err=98,end=98) line
|
|
lin=lin+1
|
|
if (line .eq. ' ') goto 9
|
|
read(line, *, err=94, end=94) x(n), y(n)
|
|
goto 3
|
|
|
|
|
|
92 call lsc_error(lin,'illegal tlim')
|
|
goto 1
|
|
93 call lsc_error(lin,'illegal range')
|
|
goto 1
|
|
94 call lsc_error(lin,'illegal datapoint')
|
|
goto 101
|
|
95 call lsc_error(lin,'illegal table no')
|
|
goto 1
|
|
96 stop 'internal error: illegal stdhdr'
|
|
97 if (.not. first) then
|
|
call lsc_error(lin,'unexpected end of file')
|
|
endif
|
|
lin=-1
|
|
RETURN
|
|
98 eof=.true.
|
|
|
|
9 x(n)=0
|
|
y(n)=0
|
|
|
|
if (n .lt. 3) call lsc_error(lin+n-1, 'not enough data points')
|
|
if (x(n-1) .lt. x(1)) then ! inverse order
|
|
j=n
|
|
do i=1,n/2
|
|
j=j-1
|
|
ex=x(i)
|
|
ey=y(i)
|
|
x(i)=x(j)
|
|
y(i)=y(j)
|
|
x(j)=ex
|
|
y(j)=ey
|
|
enddo
|
|
endif
|
|
do i=2,n-1
|
|
if (x(i) .le. x(i-1)) then
|
|
call lsc_error(lin+n, 'table not ordered')
|
|
goto 101
|
|
endif
|
|
enddo
|
|
xmax=x(n-1)
|
|
if (y(n-1) .lt. y(1)) then
|
|
coef=1
|
|
do i=2,n-1
|
|
if (y(i) .ge. y(i-1)) then
|
|
call lsc_error(lin+n, 'table not ordered')
|
|
goto 101
|
|
endif
|
|
enddo
|
|
ymax=y(1)
|
|
else
|
|
coef=2
|
|
do i=2,n-1
|
|
if (y(i) .le. y(i-1)) then
|
|
call lsc_error(lin+n, 'table not ordered')
|
|
goto 101
|
|
endif
|
|
enddo
|
|
ymax=y(n-1)
|
|
endif
|
|
101 continue
|
|
do i=1,n-1
|
|
if (x(i) .le. 0.0) call lsc_error(lin+n, 'illegal sensor value')
|
|
if (y(i) .le. 0.0) call lsc_error(lin+n, 'illegal temperature')
|
|
enddo
|
|
if (errstat .gt. 1) goto 999
|
|
|
|
sum=0
|
|
sum1=0
|
|
sum2=0
|
|
mum=0
|
|
mum1=0
|
|
mum2=0
|
|
do i=2,n-2
|
|
xi=x(i)
|
|
x1=x(i-1)
|
|
x2=x(i+1)
|
|
yi=log(y(i))
|
|
y1=y(i-1)
|
|
y2=y(i+1)
|
|
d=abs(yi-log(y1+(xi-x1)/(x2-x1)*(y2-y1)))
|
|
sum=sum+d*d
|
|
if (d .gt. mum) then
|
|
mum=d
|
|
at=y(i)
|
|
endif
|
|
xi=log(xi)
|
|
x1=log(x1)
|
|
x2=log(x2)
|
|
d=abs(yi-log(y1+(xi-x1)/(x2-x1)*(y2-y1)))
|
|
sum1=sum1+d*d
|
|
if (d .gt. mum1) then
|
|
mum1=d
|
|
at1=y(i)
|
|
endif
|
|
y1=log(y1)
|
|
y2=log(y2)
|
|
d=abs(yi-(y1+(xi-x1)/(x2-x1)*(y2-y1)))
|
|
sum2=sum2+d*d
|
|
if (d .gt. mum2) then
|
|
mum2=d
|
|
at2=y(i)
|
|
endif
|
|
enddo
|
|
if (n .gt. 3) then
|
|
sum=sqrt(sum/(n-2))*25
|
|
sum1=sqrt(sum1/(n-2))*25
|
|
sum2=sqrt(sum2/(n-2))*25
|
|
|
|
print '(x,a)','Interpolation accuracy mean worst at'
|
|
print '(13x,a,3(f8.2,a))','linear ',sum, '%',mum *25,'%',at,' K'
|
|
print '(13x,a,3(f8.2,a))','log/lin ',sum1,'%',mum1*25,'%',at1,' K'
|
|
print '(13x,a,3(f8.2,a))','log/log ',sum2,'%',mum2*25,'%',at2,' K'
|
|
|
|
if (unit .eq. 3) then
|
|
sum1=(sum1/sum)**2+(mum1/mum)**2
|
|
sum2=(sum2/sum)**2+(mum2/mum)**2
|
|
if (form .eq. 0 .and. (sum1 .lt. 1.0 .or. sum2 .lt. 1.0) &
|
|
.or. form .gt. 3) then
|
|
if (form .eq. 0 .and. sum2 .lt. sum1 .or. form .eq. 5) then
|
|
unit=5
|
|
do i=1,n-1
|
|
y(i)=log10(y(i))
|
|
enddo
|
|
else
|
|
unit=4
|
|
endif
|
|
do i=1,n-1
|
|
x(i)=log10(x(i))
|
|
enddo
|
|
endif
|
|
else
|
|
if (form .gt. 3) print *,'FORM ignored (not unit Ohm)'
|
|
endif
|
|
endif
|
|
|
|
100 continue
|
|
|
|
if (unit .eq. 1) then ! check for mV / V consistency
|
|
if (xmax .gt. 990) then
|
|
unit=2
|
|
do i=1,n-1
|
|
x(n)=x(n)/1000.0
|
|
enddo
|
|
endif
|
|
xmax=xmax/1000.0
|
|
range=range/1000.0
|
|
elseif (unit .eq. 2) then
|
|
if (xmax .lt. 0.5) then
|
|
unit=1
|
|
do i=1,n-1
|
|
x(n)=x(n)*1000.0
|
|
enddo
|
|
endif
|
|
endif
|
|
if (range .eq. 0) range=xmax
|
|
if (tlim .eq. 0 .or. tlim .gt. ymax) tlim=ymax
|
|
irange=0
|
|
if (range .gt. 0) then
|
|
if (unit .ge. 3) then ! Ohm
|
|
curr=amps(excit)
|
|
rl=range*curr ! convert Ohm to V
|
|
if (rl .gt. 5.0) then
|
|
! print *,'Warning: maximum range exceeded: ', range,'>',5/curr,' Ohm',char(7)
|
|
! errstat=max(errstat,1)
|
|
irange=12
|
|
endif
|
|
else
|
|
rl=range ! V
|
|
endif
|
|
if (irange .eq. 0) then
|
|
if (type==12) then
|
|
j=6
|
|
else
|
|
j=nvolts
|
|
end if
|
|
do i=1,j
|
|
if (rl .le. volts(i)) then
|
|
irange=i
|
|
goto 150
|
|
endif
|
|
enddo
|
|
! print *,'Warning: maximum range exceeded: ', range,' > ',volts(j),' V',char(7)
|
|
! errstat=max(errstat,1)
|
|
irange=j
|
|
150 continue
|
|
if (excit .eq. 11) then ! 10 mV excit -> min. 10 mV range
|
|
if (irange .lt. 4) irange=4
|
|
endif
|
|
endif
|
|
else
|
|
irange=defr(type)
|
|
range=xmax
|
|
endif
|
|
if (stdcurv==0) then
|
|
if (unit .ge. 3) then
|
|
if (range*amps(excit) .gt. volts(irange)) then
|
|
print *,'Warning: max. range exceeded: ',range,' > ',volts(irange)/amps(excit),' Ohm',char(7)
|
|
errstat=max(errstat,1)
|
|
endif
|
|
else if (range .gt. volts(irange)) then
|
|
print *,'Warning: max. range exceeded: ',range,' > ',volts(irange), ' V',char(7)
|
|
errstat=max(errstat,1)
|
|
endif
|
|
endif
|
|
|
|
if (type .gt. 0) then
|
|
if (excit .le. 0) excit=defe(type)
|
|
if (irange .eq. 0) irange=defr(type)
|
|
endif
|
|
print *,'Sensor type: ',types(type)
|
|
print *,'Excitation: ',excits(excit)
|
|
if (unit .eq. 1) then
|
|
print *,'Sensor Range: ',volts(irange)*1000,' mV'
|
|
elseif (unit .eq. 2) then
|
|
print *,'Sensor Range: ',volts(irange),' V'
|
|
else
|
|
print *,'Sensor Range: ',volts(irange)/amps(excit),' Ohm'
|
|
if (unit .eq. 5) then
|
|
print *,'table double logarithmic'
|
|
elseif (unit .eq. 4) then
|
|
print *,'table logarithmic'
|
|
else
|
|
print *,'table linear'
|
|
endif
|
|
endif
|
|
if (coef .eq. 1) then
|
|
print *,'negative characteristic'
|
|
else
|
|
print *,'positive characteristic'
|
|
endif
|
|
print *
|
|
|
|
if (type .eq. 0) then
|
|
if (unit .ge. 3) then
|
|
iunit=2
|
|
else
|
|
iunit=1
|
|
endif
|
|
else
|
|
if (unit .le. 2) then ! mV / V
|
|
iunit=1
|
|
else ! Ohm
|
|
iunit=2
|
|
endif
|
|
if (iunit .ne. defu(type) .or. &
|
|
coef .ne. defc(type) .or. &
|
|
excit .ne. defe(type) .or. &
|
|
irange.ne. defr(type)) then
|
|
if (type .ne. 12) type=0
|
|
endif
|
|
endif
|
|
|
|
|
|
if (type .eq. 12) then
|
|
l=5
|
|
write (line(1:l), '(a,i1)') ',,,,',max(0,irange-5)
|
|
elseif (type .eq. 0) then
|
|
l=14
|
|
write (line(1:l), '(i2,4(a,i2.0))') type,',',iunit,',',coef,',',excit,',',irange
|
|
else
|
|
l=2
|
|
write(line(1:l), '(i2)') type
|
|
endif
|
|
|
|
call str_substitute(intype, line(1:l), ' ', char(0))
|
|
call str_trim(intype, intype, li)
|
|
|
|
if (tlim .gt. 1500) tlim=1500
|
|
if (tlim .lt. 0) tlim=0
|
|
|
|
if (stdcurv==0) then
|
|
! calculate crc of table
|
|
crc=0
|
|
do i=1,n,ncolumn
|
|
call pack(line, l, x(i), y(i), i-1, 1)
|
|
call str_crc(crc, line(1:l))
|
|
enddo
|
|
call str_crc_comp(crc, crcmp)
|
|
write (header, "(a,x,a,',',a,',',i1,',',f8.3,',',i1)") name(1:11), crcmp,sensor,unit,tlim,coef
|
|
else
|
|
header=stdhdr(stdcurv)
|
|
endif
|
|
|
|
! compare with old file
|
|
call str_trim(filnam, name, l)
|
|
filnam(l+1:)='.crv'
|
|
filnam='tecs/'//filnam
|
|
open(unit=2, file=filnam, status='old', action='read',err=198)
|
|
read(2, '(a)',end=199) old
|
|
if (old/=header) goto 199
|
|
read(2, '(a)', end=199) old
|
|
if (old/=intype) goto 199
|
|
do i=1,n,ncolumn
|
|
read(2, '(a)') old
|
|
call pack(line, l, x(i), y(i), i-1, min(ncolumn,n-i+1))
|
|
if (line/=old) goto 199
|
|
enddo
|
|
close(2)
|
|
print *,'curve file has not changed: ',filnam
|
|
goto 999
|
|
|
|
198 print *,'create new curve file: ',filnam
|
|
nlist=nlist+1
|
|
list(nlist)='created '//filnam
|
|
goto 200
|
|
|
|
199 close(2)
|
|
print *,'modify curve file: ',filnam
|
|
nlist=nlist+1
|
|
list(nlist)='modified '//filnam
|
|
200 continue
|
|
open(unit=2, file=filnam, status='unknown', action='write', carriagecontrol='list')
|
|
call str_trim(header, header, l)
|
|
if (stdcurv/=0) then
|
|
write(2, '(a)') header(1:l)
|
|
write(2, '(a)') intype(1:li)
|
|
write(2, '(a,i2)') '$',stdcurv
|
|
else
|
|
write(2, '(a)') header(1:l)
|
|
write(2, '(a)') intype(1:li)
|
|
do i=1,n,ncolumn
|
|
call pack(line, l, x(i), y(i), i-1, min(ncolumn,n-i+1))
|
|
write(2,'(a)') line(1:l)
|
|
enddo
|
|
endif
|
|
close(2)
|
|
999 continue
|
|
if (errstat .gt. 0) then
|
|
if (name==' ') name='<unknown>'
|
|
nlist=nlist+1
|
|
if (errstat .gt. 1) then
|
|
list(nlist)='error in '//file//', curve '//name
|
|
print *,'no curve file written'
|
|
lin=-1
|
|
else
|
|
list(nlist)='warning in '//file//', curve '//name
|
|
endif
|
|
endif
|
|
if (eof) lin=-1
|
|
return
|
|
end subroutine
|
|
|
|
|
|
integer function lsc_getno(list, n, name)
|
|
|
|
integer n
|
|
character list(n)*(*), name*(*)
|
|
character str*32
|
|
|
|
integer i,l
|
|
|
|
call str_trim(name, name, l)
|
|
l=min(l,len(str))
|
|
do i=1,n
|
|
call str_upcase(str(1:l), list(i))
|
|
if (name(1:l) .eq. str(1:l)) then
|
|
lsc_getno=i
|
|
RETURN
|
|
endif
|
|
enddo
|
|
lsc_getno=0
|
|
end function
|
|
|
|
|
|
subroutine lsc_errinit(lunit)
|
|
|
|
integer lunit
|
|
|
|
lun=lunit
|
|
pos=0
|
|
errstat=0
|
|
end subroutine
|
|
|
|
subroutine lsc_error(lin, text)
|
|
|
|
integer lin
|
|
character text*(*)
|
|
|
|
integer i,l
|
|
character line*132
|
|
|
|
if (pos .eq. 0) then
|
|
print *
|
|
endif
|
|
if (lin .gt. pos) then
|
|
rewind lun
|
|
do i=1,lin-1
|
|
read(lun, '(q,a)', end=8) l,line
|
|
if (i .gt. max(pos,lin-3)) then
|
|
print '(5x,a)',line(1:max(1,min(l,len(line))))
|
|
endif
|
|
enddo
|
|
read(lun, '(q,a)', end=8) l,line
|
|
print '(x,2a)','>>> ',line(1:max(1,min(l,len(line))))
|
|
8 pos=lin
|
|
errstat=2
|
|
endif
|
|
|
|
9 print '(x,a)', text
|
|
end subroutine
|
|
|
|
end program
|