736 lines
17 KiB
Fortran
736 lines
17 KiB
Fortran
program conv
|
|
|
|
include 'conv.inc'
|
|
|
|
logical init
|
|
integer i,j,l,lin,iostat
|
|
character*128 line
|
|
character*2048 input
|
|
|
|
data lun/0/,pos/0/,nlist/0/
|
|
|
|
path=' '
|
|
lp=0
|
|
verbose=.false.
|
|
call sys_get_cmdpar(input, l)
|
|
if (input .eq. ' ') then
|
|
verbose=.true.
|
|
print '(a,$)',
|
|
1' File(s) (separated with space): '
|
|
read(*,'(a)',end=99) input
|
|
if (input .eq. ' ') goto 99
|
|
endif
|
|
i=index(input, '-p')
|
|
if (i .ne. 0) then ! first path option valid from start
|
|
j=index(input(i+1:), ' ')
|
|
call str_trim(path, input(i+2:i+j), lp)
|
|
endif
|
|
i=0
|
|
do while (input(i+1:) .ne. ' ')
|
|
j=index(input(i+1:), ' ')
|
|
if (j .le. 1) then
|
|
i=i+1
|
|
else if (input(i+1:i+2) .eq. '-p') then
|
|
call str_trim(path, input(i+3:i+j), lp)
|
|
i=i+j
|
|
else if (input(i+1:i+1) .eq. '-') then
|
|
print *,'unknown option: ',input(i+1:i+j)
|
|
i=i+j
|
|
else
|
|
call str_trim(file, input(i+1:i+j), lf)
|
|
i=i+j
|
|
if (verbose) print *
|
|
open(1,name=file(1:lf),status='old',iostat=iostat)
|
|
if (iostat .ne. 0) then
|
|
if (verbose) then
|
|
print *,'can not open ',file(1:lf)
|
|
print "(x,60('-'))"
|
|
endif
|
|
nlist=nlist+1
|
|
list(nlist)='can not open '//file(1:lf)
|
|
else
|
|
lin=0
|
|
do
|
|
call lsc_errinit(1) ! 1=lun
|
|
call lsc_convert_table(lin)
|
|
if (lin .lt. 0) goto 19
|
|
if (verbose) print "(x,60('-'))"
|
|
enddo
|
|
19 continue
|
|
close(1)
|
|
endif
|
|
endif
|
|
enddo
|
|
|
|
do i=1,nlist
|
|
call str_trim(list(i), list(i), l)
|
|
print *,list(i)(1:l)
|
|
enddo
|
|
|
|
99 continue
|
|
end
|
|
|
|
|
|
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 cvt_real_str(line(p+1:), l, 1.0*(offset+j), 1, 0, 6, 3)
|
|
p=p+l
|
|
call str_append(line, p, ':')
|
|
call cvt_real_str(line(p+1:), l, x(j), 1, 0, 6, 3)
|
|
p=p+l
|
|
call str_append(line, p, ',')
|
|
call cvt_real_str(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 lsc_convert_table(lin)
|
|
|
|
implicit none
|
|
include 'conv.inc'
|
|
|
|
integer lin
|
|
|
|
integer ntypes,nvolts, namps
|
|
parameter (ntypes=12, nvolts=12, namps=12)
|
|
integer np
|
|
|
|
real x(200), y(200), ex, ey
|
|
integer i,j,l,p,li,crc,form,iostat
|
|
|
|
character name*15, sensor*10, header*64, line*128, old*128, intype*16
|
|
character crcmp*3, filnam*128, cfgdir*128
|
|
character c40*40/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ$+-&'/
|
|
integer unit, stype, excit, irange, coef, iunit, stdcurv
|
|
! codes
|
|
character types(0:ntypes)*12/'Special','Si Diode','GaAlAs Diode'
|
|
1 ,'Pt250 Ohm','Pt500 Ohm','Pt2500 Ohm','RhFe','C-Glass'
|
|
1 ,'Cernox','RuOx','Ge','Cap','Tc'/
|
|
integer nunits
|
|
parameter (nunits=3)
|
|
character units(nunits)*5/'mV','V','Ohm'/
|
|
integer nexcits
|
|
parameter (nexcits=12)
|
|
character excits(0:nexcits)*8/'Off','30nA','100nA','300nA','1uA','3uA'
|
|
1 ,'10uA','30uA','100uA','300uA','1mA','10mV','1mV'/
|
|
integer nforms
|
|
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
|
|
1 ,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
|
|
1 ,3E-8,3E-8/ ! minimal values are for voltage excitation
|
|
integer stdmax
|
|
parameter (stdmax=10)
|
|
character*40 stdhdr(stdmax)/
|
|
1 'DT-470 ,Standard ,2,+475.000E+0,1',
|
|
1 'DT-500-D ,Standard ,2,+365.000E+0,1',
|
|
1 'DT-500-E1 ,Standard ,2,+330.000E+0,1',
|
|
1 'PT-100 ,Standard ,3,+800.000E+0,2',
|
|
1 'PT-1000 ,Standard ,3,+800.000E+0,2',
|
|
1 'TYPE K ,Standard ,1,+1645.00E+0,2',
|
|
1 'TYPE E ,Standard ,1,+1188.50E+0,2',
|
|
1 'TYPE T ,Standard ,1,+673.000E+0,2',
|
|
1 'CrAuFe.03%,Standard ,1,+500.000E+0,2',
|
|
1 '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, inverted
|
|
|
|
! functions
|
|
integer lsc_getno
|
|
external lsc_getno, pack
|
|
|
|
first=.true.
|
|
eof=.false.
|
|
np=0
|
|
name=' '
|
|
sensor=' '
|
|
unit=0
|
|
tlim=0
|
|
stype=0
|
|
excit=0
|
|
form=0
|
|
range=-1.0
|
|
stdcurv=0
|
|
1 read(1,'(a)',err=97,end=97) line
|
|
call str_trim(line, line, l)
|
|
lin=lin+1
|
|
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. 'SENS') then
|
|
sensor=line(i:l)
|
|
name=sensor
|
|
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
|
|
stype=lsc_getno(types, ntypes+1, line(i:l))-1
|
|
if (stype .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 (sensor .eq. ' ') call lsc_error(lin, 'missing sensor name')
|
|
i=index(line,'=')
|
|
if (i .ne. 0) then
|
|
read(line(i+1:l), *, err=2,end=2) stdcurv
|
|
2 continue
|
|
if (stdcurv .lt. 0 .or. stdcurv .gt. stdmax) then
|
|
call lsc_error(lin, 'illegal standard curve no.')
|
|
goto 101
|
|
endif
|
|
if (unit .ne. 0 .or. stype .ne. 0 .or.
|
|
1 excit .ne. 0 .or. tlim .ne. 0) then
|
|
if (verbose) then
|
|
print *,'Warning: all parameters except "sens"'
|
|
1 ,', "range" and "curv" are ignored',char(7)
|
|
endif
|
|
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
|
|
stype=stdtype(stdcurv)
|
|
! if (range .lt. 0) then
|
|
! range=stdrange(stdcurv)
|
|
! end if
|
|
xmax=0
|
|
excit=0
|
|
tlim=0
|
|
goto 100
|
|
endif
|
|
if (line(5:) .ne. ' ') then
|
|
call lsc_error(lin, 'missing "="')
|
|
goto 101
|
|
end if
|
|
! user curve
|
|
if (unit .eq. 0) call lsc_error(lin, 'missing unit')
|
|
if (stype .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(stype)
|
|
endif
|
|
3 np=np+1
|
|
read(1,'(a)',err=98,end=98) line
|
|
lin=lin+1
|
|
if (line .eq. ' ') goto 9
|
|
read(line, *, err=94, end=94) x(np), y(np)
|
|
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 np=np-1 ! point (np) is not valid
|
|
|
|
if (np .lt. 2) call lsc_error(lin+np, 'not enough data points')
|
|
if (x(np) .lt. x(1)) then ! inverse order
|
|
j=np
|
|
do i=1,np/2
|
|
ex=x(i)
|
|
ey=y(i)
|
|
x(i)=x(j)
|
|
y(i)=y(j)
|
|
x(j)=ex
|
|
y(j)=ey
|
|
j=j-1
|
|
enddo
|
|
inverted=.true.
|
|
else
|
|
inverted=.false.
|
|
endif
|
|
do i=2,np
|
|
if (x(i) .le. x(i-1)) then
|
|
j=i
|
|
if (inverted) j=np-i+1
|
|
call lsc_error(lin+j, 'table not ordered')
|
|
goto 101
|
|
endif
|
|
enddo
|
|
xmax=x(np)
|
|
if (y(np) .lt. y(1)) then
|
|
coef=1
|
|
do i=2,np
|
|
if (y(i) .ge. y(i-1)) then
|
|
j=i
|
|
if (inverted) j=np-i+1
|
|
call lsc_error(lin+j, 'table not ordered')
|
|
goto 101
|
|
endif
|
|
enddo
|
|
ymax=y(1)
|
|
else
|
|
coef=2
|
|
do i=2,np
|
|
if (y(i) .le. y(i-1)) then
|
|
j=i
|
|
if (inverted) j=np-i+1
|
|
call lsc_error(lin+j, 'table not ordered')
|
|
goto 101
|
|
endif
|
|
enddo
|
|
ymax=y(np)
|
|
endif
|
|
101 continue
|
|
do i=1,np
|
|
if (x(i) .eq. 0.0) then
|
|
j=i
|
|
if (inverted) j=np-i+1
|
|
call lsc_error(lin+j, 'illegal sensor value')
|
|
endif
|
|
if (y(i) .le. 0.0) then
|
|
j=i
|
|
if (inverted) j=np-i+1
|
|
call lsc_error(lin+j, 'illegal temperature')
|
|
endif
|
|
enddo
|
|
if (errstat .gt. 1) goto 999
|
|
|
|
sum=0
|
|
sum1=0
|
|
sum2=0
|
|
mum=0
|
|
mum1=0
|
|
mum2=0
|
|
do i=2,np-1
|
|
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(abs(xi))
|
|
x1=log(abs(x1))
|
|
x2=log(abs(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 (np .gt. 2) then
|
|
sum=sqrt(sum/(np-1))*25
|
|
sum1=sqrt(sum1/(np-1))*25
|
|
sum2=sqrt(sum2/(np-1))*25
|
|
|
|
if (verbose) then
|
|
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'
|
|
endif
|
|
|
|
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)
|
|
1 .or. form .gt. 3) then
|
|
if (form .eq. 0 .and. sum2 .lt. sum1 .or. form .eq. 5) then
|
|
unit=5
|
|
do i=1,np
|
|
y(i)=log10(y(i))
|
|
enddo
|
|
else
|
|
unit=4
|
|
endif
|
|
do i=1,np
|
|
x(i)=log10(x(i))
|
|
enddo
|
|
endif
|
|
else
|
|
if (form .gt. 3 .and. verbose)
|
|
1 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,np
|
|
x(i)=x(i)/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,np
|
|
x(i)=x(i)*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: '
|
|
! 1 , range,'>',5/curr,' Ohm',char(7)
|
|
! errstat=max(errstat,1)
|
|
irange=12
|
|
endif
|
|
else
|
|
rl=range ! V
|
|
endif
|
|
if (irange .eq. 0) then
|
|
if (stype.eq.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(stype)
|
|
range=xmax
|
|
endif
|
|
if (stdcurv.eq.0) then
|
|
if (unit .ge. 3) then
|
|
if (range*amps(excit) .gt. volts(irange)) then
|
|
print *,'Warning: max. range exceeded: '
|
|
1 ,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: '
|
|
1 ,range,' > ',volts(irange), ' V',char(7)
|
|
errstat=max(errstat,1)
|
|
endif
|
|
endif
|
|
|
|
if (stype .gt. 0) then
|
|
if (excit .le. 0) excit=defe(stype)
|
|
if (irange .eq. 0) irange=defr(stype)
|
|
endif
|
|
if (verbose) then
|
|
print *,'Sensor type: ',types(stype)
|
|
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 *
|
|
endif
|
|
|
|
if (stype .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(stype) .or.
|
|
1 coef .ne. defc(stype) .or.
|
|
1 excit .ne. defe(stype) .or.
|
|
1 irange.ne. defr(stype)) then
|
|
if (stype .ne. 12) stype=0
|
|
endif
|
|
endif
|
|
|
|
|
|
if (stype .eq. 12) then
|
|
l=5
|
|
write (line(1:l), '(a,i1)') ',,,,',max(0,irange-5)
|
|
elseif (stype .eq. 0) then
|
|
l=14
|
|
write (line(1:l), '(i2,4(a,i2.0))')
|
|
1 stype,',',iunit,',',coef,',',excit,',',irange
|
|
else
|
|
l=2
|
|
write(line(1:l), '(i2)') stype
|
|
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.eq.0) then
|
|
! calculate crc of table
|
|
crc=0
|
|
do i=1,np
|
|
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)")
|
|
1 name(1:11), crcmp,sensor,unit,tlim,coef
|
|
else
|
|
crc=0
|
|
header=stdhdr(stdcurv)
|
|
endif
|
|
|
|
! compare with old file
|
|
call str_trim(filnam, sensor, l)
|
|
call str_lowcase(filnam, filnam)
|
|
filnam(l+1:)='.crv'
|
|
if (path(1:lp) .ne. ' ') then
|
|
filnam=path(1:lp)//filnam
|
|
endif
|
|
open(unit=2, file=filnam, status='old', iostat=iostat)
|
|
if (iostat .ne. 0) goto 198
|
|
read(2, '(a)',end=199) old
|
|
if (old .ne. header) goto 199
|
|
read(2, '(a)', end=199) old
|
|
if (old .ne. intype) goto 199
|
|
if (stdcurv .ne. 0) then
|
|
write(line, '(a, i2)') '$',stdcurv
|
|
read(2, '(a)', end=199) old
|
|
if (line .ne. old) goto 199
|
|
read(2, '(a)', end=197) old ! goto end (o.k.) if no more line
|
|
goto 199
|
|
endif
|
|
do i=1,np,ncolumn
|
|
read(2, '(a)', end=199) old
|
|
call pack(line, l, x(i), y(i), i-1, min(ncolumn,np-i+1))
|
|
if (line .ne. old) goto 199
|
|
enddo
|
|
read(2, '(a)', end=199) old
|
|
call pack(line, l, 0.0, 0.0, np, 1)
|
|
if (line .ne. old) goto 199
|
|
read(2, '(a)', end=197) old ! goto end (o.k.) if no more line
|
|
goto 199
|
|
197 close(2)
|
|
if (verbose) print *,'curve file has not changed: ',filnam
|
|
goto 200
|
|
! goto 999
|
|
|
|
198 if (verbose) print *,'create new curve file: ',filnam
|
|
nlist=nlist+1
|
|
list(nlist)='created '//filnam
|
|
goto 200
|
|
|
|
199 close(2)
|
|
if (verbose) print *,'modify curve file: ',filnam
|
|
nlist=nlist+1
|
|
list(nlist)='modified '//filnam
|
|
200 continue
|
|
open(unit=2, file=filnam, status='unknown', iostat=iostat)
|
|
if (iostat .ne. 0) then
|
|
call str_trim(filnam, filnam, l)
|
|
print *,'can not open ',filnam(1:l)
|
|
nlist=nlist-1
|
|
lin=-1
|
|
return
|
|
endif
|
|
call str_trim(header, header, l)
|
|
write(2, '(a)') header(1:l)
|
|
write(2, '(a)') intype(1:li)
|
|
if (stdcurv .ne. 0) then
|
|
write(2, '(a,i2)') '$',stdcurv
|
|
else
|
|
do i=1,np,ncolumn
|
|
call pack(line, l, x(i), y(i), i-1, min(ncolumn,np-i+1))
|
|
write(2,'(a)') line(1:l)
|
|
enddo
|
|
call pack(line, l, 0.0, 0.0, np, 1)
|
|
write(2,'(a)') line(1:l)
|
|
endif
|
|
close(2)
|
|
999 continue
|
|
if (errstat .gt. 0) then
|
|
if (name.eq.' ') name='<unknown>'
|
|
nlist=nlist+1
|
|
if (errstat .gt. 1) then
|
|
list(nlist)='error in '//file(1:lf)//', curve '//name
|
|
if (verbose) print *,'no curve file written'
|
|
lin=-1
|
|
else
|
|
list(nlist)='warning in '//file(1:lf)//', curve '//name
|
|
endif
|
|
endif
|
|
if (eof) lin=-1
|
|
return
|
|
end
|
|
|
|
|
|
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
|
|
|
|
|
|
subroutine lsc_errinit(lunit)
|
|
|
|
include 'conv.inc'
|
|
|
|
integer lunit
|
|
|
|
lun=lunit
|
|
pos=0
|
|
errstat=0
|
|
end
|
|
|
|
|
|
subroutine lsc_error(lin, text)
|
|
|
|
include 'conv.inc'
|
|
|
|
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, '(a)', end=8) line
|
|
call str_trim(line, line, l)
|
|
if (i .gt. max(pos,lin-3)) then
|
|
print '(5x,a)',line(1:l)
|
|
endif
|
|
enddo
|
|
read(lun, '(a)', end=8) line
|
|
call str_trim(line, line, l)
|
|
print '(x,2a)','>>> ',line(1:l)
|
|
8 pos=lin
|
|
errstat=2
|
|
endif
|
|
|
|
9 print '(x,a)', text
|
|
end
|