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