c
c     Copyright (c) 1999,2000, Compaq Computer Corporation
c
c     See the file "license.terms" for information on usage and redistribution
c     of this file, and for a DISCLAIMER OF ALL WARRANTIES.
c
c     Print line utilities
c
      subroutine print_line
      implicit none
c
c     Asks user what array to print, then prints a vertical or 
c     horizontal line in array to file.
c
c     Programmer: John Faricelli
c     Date: 5-Jun-85
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'mesh.cmn'
      include 'data.cmn'
      include 'io.cmn'
      include 'bincodes.cmn'
c
c     locals
c
      logical error
      integer answer, ilen, istatus, string_len
      character*(PM_MAX_PATHLEN) tmpname
      character*10 buffer
      character*80 errfmt
c
      errfmt = '('' '')'
c
c     Short circuit this menu if there is only one data item to select from
c
      if( max_menu_num .eq. 1 ) then
c        Load Grapes data, if needed...
         if( binfiletype .eq. DT_GRAPES ) then
            call pm_select_grapes_data(error)
            if( error ) return
         endif
c        Load SPICE3 data, if needed...
         if( binfiletype .eq. DT_SPICE3 ) then
            call pm_select_spice3_data(error)
            if( error ) return
         endif
         if( data_is_trigrid ) then
            call ship_line_tri(arrdat(arrind(menu_to_arr(1))),
     1                     tri_npts, does_data_jump_at_oxide(1),
     2                     is_data_log(1),
     3                     data_name(1), data_units(1),
     4                     data_file_ext(1), tmpname, istatus)
         else if( is_data_1d(1) ) then
            ilen = string_len(binfilestem)
            tmpname = binfilestem(1:ilen) // data_file_ext(1)
            call prline(arr2d(1,menu_to_arr(1)), ni,
     1                  xyz(1,idisti), 0.0,
     2                  data_name(1), data_units(1), charv,
     3                  tmpname, istatus)
            if( istatus .eq. 0 ) then
               ilen = string_len(tmpname)
               errfmt = '('' '',''Wrote file: ' // tmpname(1:ilen) //
     1                  ''')'
               call beep_terminal
            endif
         else
            call ship_line(arrdat(arrind(menu_to_arr(1))),
     1                     ni, nj, does_data_jump_at_oxide(1),
     2                     data_name(1), data_units(1),
     3                     data_file_ext(1), tmpname, istatus)
         endif
         return
      endif
c
200   call clear_screen
      write(luttyo,errfmt)
      errfmt = '('' '')'
      call write_data_menu('Print line section:')
      write(luttyo,105)
105   format(/' ','Request? ',$)
      read(luttyi,106,err=300,end=300) buffer
106   format(a)
      call upcase(buffer)
      if( string_len(buffer) .eq. 0 ) then
         answer = EXIT_MENU
      else if( buffer(1:1) .eq. 'Q' .or.  buffer(1:1) .eq. 'E' ) then
         answer = EXIT_MENU
      else
         read(buffer,*,err=300) answer
      endif
c
c    Error check:
c       1) Exit menu
c       2) Answer in range
c       3) Is requested data in binary file?
c
      if( answer .eq. EXIT_MENU ) then
         goto 1000
      else if ( answer .lt. 1 .or. answer .gt. max_menu_num ) then
         errfmt = '('' '',''Invalid input: Please try again...'')'
         call beep_terminal
      else if( .NOT. in_binary_file(answer) ) then
         errfmt = '('' '',''Data not available from binary file'')'
         call beep_terminal
      else if( is_data_1d(answer) ) then
         ilen = string_len(binfilestem)
         tmpname = binfilestem(1:ilen) // data_file_ext(answer)
         call prline(arr2d(1,menu_to_arr(answer)), ni,
     1               xyz(1,idisti), 0.0,
     2               data_name(answer), data_units(answer), charv,
     3               tmpname, istatus )
         if( istatus .eq. 0 ) then
            ilen = string_len(tmpname)
            errfmt = '('' '',''Wrote file: ' // tmpname(1:ilen) // ''')'
            call beep_terminal
         endif
      else
         if( data_is_trigrid ) then
            call ship_line_tri(arrdat(arrind(menu_to_arr(answer))),
     1                     tri_npts, does_data_jump_at_oxide(answer),
     2                     is_data_log(answer),
     3                     data_name(answer), data_units(answer),
     4                     data_file_ext(answer), tmpname, istatus)
         else
            call ship_line(arrdat(arrind(menu_to_arr(answer))),
     1                     ni, nj, does_data_jump_at_oxide(answer),
     2                     data_name(answer), data_units(answer),
     3                     data_file_ext(answer), tmpname, istatus)
         endif
         if( istatus .eq. 0 ) then
            ilen = string_len(tmpname)
            errfmt = '('' '',''Wrote file: ' // tmpname(1:ilen) // ''')'
            call beep_terminal
         endif
      endif
      goto 200
c
c     illegal input
300   errfmt = '('' '',''Invalid input: Please try again...'')'
      call beep_terminal
      goto 200
c
1000  continue
      return
      end
c
      subroutine ship_line(data_array, max_h, max_v,
     1                     discontinuity, label, units, ext, filename,
     1                     istatus)
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'mesh.cmn'
      include 'data.cmn'
      include 'io.cmn'
      include 'units.cmn'
c
      integer V_CUT, H_CUT
      parameter (V_CUT = 1, H_CUT = 2)
c
      integer max_h, max_v, istatus
      logical discontinuity
      real data_array(max_h, max_v)
      character*(*) label, units, ext, filename
c
c     locals
c
      real value, real_vec(10)
      real line1(COMP_ARRAYSIZE), line2(COMP_ARRAYSIZE),
     1     result(COMP_ARRAYSIZE)
      integer type, index, discont_type, ulen, ilen, string_len
      integer i, j
      character*4 position, cvt_real_4digitchar
      character*10 answer
c
      integer getindex  ! function
c
      ulen = string_len(pm_length_unit)
c
c     Ask user for horizontal or vertical line
99    call get_char(answer,'Vertical or horizontal line (V or H)? ',0)
      call upcase(answer)
      if ( answer(1:1) .eq. 'V' ) then
         type = V_CUT
      else if ( answer(1:1) .eq. 'H' ) then
         type = H_CUT
      else
         write(luttyo,102) answer
102      format(' ','Invalid response: ', a)
         goto 99
      endif
c
c     Ask user for line value to print
c
200   if( type .eq. V_CUT ) then
         write(luttyo,110) charh, pm_scale_cm2plot*xyz(1,idisti),
     1                     charh, pm_scale_cm2plot*xyz(ni,idisti)
110      format(' ','Minimum ',a1,' = ',1pg12.5,
     1              '; Maximum ',a1,' = ',1pg12.5)
      else
         write(luttyo,110) charv, pm_scale_cm2plot*xyz(1,idistj),
     1                     charv, pm_scale_cm2plot*xyz(nj,idistj)
       endif
c
      call get_reals(real_vec,1,'Enter coordinate value in ' //
     1               pm_length_unit(1:ulen) // ': ',0)
      value = real_vec(1)*pm_scale_plot2cm
c
c     warn user if he selects a quantity that has a discontinuity
c     at the oxide and semiconductor interface...
      discont_type = 999
      if( type .eq. H_CUT .and. value .eq. 0.0
     1                    .and. discontinuity ) then
135      write(luttyo,136)
136      format(' ','Warning: field is discontinuous at y=0.0'/
     1   ' ','Do you want field at closest line in oxide (-1),'/
     1   ' ','   semiconductor (1), or average (0)? ',$)
         read(luttyi,*) discont_type
         if( discont_type .lt. -1 .or. discont_type .gt. 1 ) then
            write(luttyo,137) discont_type
137         format(' ','Illegal response: ',i5)
            goto 135
            endif
      endif
c
c     get equivalent index in array
      if( type .eq. V_CUT ) then     ! vertical cut
         index = getindex(value, xyz(1,idisti), ni)
      else
         index = getindex(value, xyz(1,idistj), nj) ! horizontal cut
      endif
      if( index .eq. 0 ) then
         write(luttyo,140) value
140      format(' ','Value ',1pe10.3,' not in array bounds')
         goto 200
      endif
c
      position = cvt_real_4digitchar(value,pm_scale_cm2plot)
      ilen = string_len(binfilestem)
      if( type .eq. V_CUT ) then
         filename = binfilestem(1:ilen) // '_' // position // charh //
     1              ext
      else
         filename = binfilestem(1:ilen) // '_' // position // charv //
     1              ext
      endif

      if( type .eq. V_CUT ) then
         do 210 j=1,nj
            line1(j) = data_array(index,j)
            line2(j) = data_array(index+1,j)
210         continue
         call interp_line(line1, line2, result, nj,
     1      xyz(index,idisti), xyz(index+1,idisti), value)
         call prline(result, nj, xyz(1,idistj), value,
     1               label, units, charh, filename, istatus)
      else
         if( discont_type .ne. 999 ) then
c           special handling of interface...
c           choose either oxide, interface or semiconductor
            if( discont_type .eq. -1 ) then
c              take one step up into oxide
               index = index - 1
               value = xyz(index,idistj)
            else if( discont_type .eq. 1 ) then
c              take one step down into semiconductor
               index = index + 1
               value = xyz(index,idistj)
            endif
         endif
         do 220 i=1,ni
            line1(i) = data_array(i,index)
            line2(i) = data_array(i,index+1)
220         continue
         call interp_line( line1, line2, result, ni,
     1      xyz(index,idistj), xyz(index+1,idistj), value)
         call prline(result, ni, xyz(1,idisti), value,
     1               label, units, charv, filename, istatus)
      endif
c
      return
      end
c
      subroutine ship_line_tri(data_array, array_size,
     1                     discontinuity, llog,
     1                     label, units, ext, filename, istatus)
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'mesh.cmn'
      include 'data.cmn'
      include 'io.cmn'
      include 'units.cmn'
c
      integer V_CUT, H_CUT
      parameter (V_CUT = 1, H_CUT = 2)
c
      integer array_size, istatus
      logical discontinuity, llog
      real data_array(array_size)
      character*(*) label, units, ext, filename
c
c     locals
c
      real cut_line_coord, dmin, dmax, real_vec(1)
c     We make tmp larger than needed because in a cut line extraction
c     on a triangular grid, a cut line can generate multiple
c     intersections (two per triangle element).
      real tmp(4*COMP_ARRAYSIZE,2)
      integer ulen, ilen, string_len
      integer type, np
      logical lerr, along_oxide, value_in_oxide
      character*4  position, cvt_real_4digitchar
      character*10 answer
      character*1  cutchar
c
      ulen = string_len(pm_length_unit)
c
c     Ask user for horizontal or vertical line
99    call get_char(answer,'Vertical or horizontal line (V or H)? ',0)
      call upcase(answer)
      if ( answer(1:1) .eq. 'V' ) then
         type = V_CUT
      else if ( answer(1:1) .eq. 'H' ) then
         type = H_CUT
      else
         write(luttyo,102) answer
102      format(' ','Invalid response: ', a)
         goto 99
      endif
c
c     Ask user for line value to print
c
      if( type .eq. V_CUT ) then
         cutchar = charh
         dmin = xyzlimits(1,idisti)
         dmax = xyzlimits(2,idisti)
      else if ( type .eq. H_CUT ) then
         cutchar = charv
         dmin = xyzlimits(1,idistj)
         dmax = xyzlimits(2,idistj)
      endif
200   write(luttyo,110)
     1                cutchar, pm_scale_cm2plot*dmin,
     1                pm_length_unit(1:ulen),
     1                cutchar, pm_scale_cm2plot*dmax,
     1                pm_length_unit(1:ulen)
110   format(' ','The minimum ',a1,' coordinate in the device is ',
     1          1pg12.5, ' ',a/
     1          ' ','The maximum ',a1,' coordinate in the device is ',
     1          1pg12.5, ' ',a)
c
      call get_reals(real_vec,1,'Enter coordinate value in ' //
     1               pm_length_unit(1:ulen) // ': ',0)
      cut_line_coord = real_vec(1)*pm_scale_plot2cm
      if( cut_line_coord .lt. dmin .or. cut_line_coord .gt. dmax ) then
         write(luttyo,120) cut_line_coord*pm_scale_cm2plot
120      format(' ','Error: Cut line value ',1pe10.3,
     1          ' is outside device')
         goto 200
      endif
c
c     Ignore discontinuities for now...
c
      value_in_oxide = .TRUE.
      along_oxide = .FALSE.
      call extract_cut_line_tri(data_array, array_size,
     1                     discontinuity,
     2                     llog, value_in_oxide,
     3                     cut_line_coord, cutchar,
     4                     along_oxide,
     5                     tmp, 4*COMP_ARRAYSIZE, 2, np, lerr)
      if( lerr ) then
         write(luttyo,130)
130      format(' ','Error occured during cut line select')
         if( np .eq. 0 ) write(luttyo,140)
140      format(' ','No points selected')
         call get_char(answer,'Hit return to continue',0)
         return
      endif
c
c     Check for possible array overflow. Note that plot_line stores
c     data into work_vec, which is sized COMP_ARRAYSIZE.
      if( np .gt. COMP_ARRAYSIZE ) then
         write(luttyo,150)
150      format(' ','Internal storage limit exceeded during select')
         call get_char(answer,'Hit return to continue',0)
      endif
c
      position = cvt_real_4digitchar(cut_line_coord,pm_scale_cm2plot)
      ilen = string_len(binfilestem)
      filename = binfilestem(1:ilen) // '_' // position // cutchar
     1           // ext
c
      call prline(tmp(1,1), np, tmp(1,2), cut_line_coord,
     1            label, units, cutchar, filename, istatus)
c
      return
      end
c
      integer function getindex(value, vector, maxindex)
      implicit none
c
c     Find the element in array 'vector' that is just below
c     'value'. Return the index of that element.
c     'maxindex' is length of coords.
c
      real value, vector(1)
      integer maxindex
c
c     locals
      integer i
c
      if( value .lt. vector(1) ) then
         getindex = 0
         return
      endif
      do 10 i=2,maxindex
         if( value .lt. vector(i) ) then
            getindex = i-1
            return
         endif
10       continue
c
      if( value .eq. vector(maxindex) ) then
         getindex = maxindex-1
      else
         getindex = 0
      endif
c
      return
      end
c
      subroutine interp_line(line1, line2, result, n, d0, d1, dinterp)
      implicit none
c
c     Linear interpolate a vector of data between line1 and line2.
c     Put result in result. line1 data occurs at distance d0,
c     line2's data occurs at d1; interpolate at dinterp.
c
      integer n
      real line1(n), line2(n), result(n), d0, d1, dinterp
c
c     locals
c
      integer i
      real delta
c
      delta = (dinterp - d0)/(d1-d0)
      do 10 i=1,n
         result(i) = line1(i) + (line2(i) - line1(i))*delta
10    continue
      return
      end
c
      subroutine prline(result, n, dist, value, label, units, axis,
     1                  filename, istatus)
      implicit none
c
c     Print a line of data to file
c
      integer n, istatus
      real result(n), dist(n), value
      character*(*) label, units, filename
      character*1 axis, ch
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'io.cmn'
      include 'units.cmn'
c
c     locals
c
      integer i, ierr, ioerr, nrecl, string_len
c
      nrecl=0
      call pm_open_file(luprint, filename,
     1                  'NEW','FORMATTED','READWRITE','LIST',
     2                  'NONSHARED',nrecl,ioerr,ierr)
      if( ierr .ne. 0 ) goto 1000
c
c     print header
      write (luprint,100) label, units, axis, pm_scale_cm2plot*value
100   format('C',4x,a,t51,a,t61,'at ',a1,'= ',1pg12.5)
c
      do 20 i=1,n
         write (luprint,101) pm_scale_cm2plot*dist(i), result(i)
101      format(' ',1pe12.3,2x,1pe12.3)
20    continue
c
      close(unit=luprint)
      istatus = 0
      goto 2000
c
1000  continue
      i = string_len(filename)
      write(luttyo,1001) ioerr, filename(1:i)
1001  format(' ','FORTRAN I/O error #',i5,' on open of file'/
     1       ' ',a)
      call get_char(ch,'Hit return to continue ',0)
      istatus = ioerr
2000  continue
      return
      end
c
      character*4 function cvt_real_4digitchar(value, scale)
      implicit none
c
      real value, scale
c
c     Scale 'value' by 'scale'.
c     convert real number in range -9.999 to 9.999 to three digit character
c     value. Negative sign is ignored. Numbers out of range are
c     signaled by returning 'ZZZZ'
c
c     examples:
c        0.34  -> '0340'    1.22  ->  '1220'   -0.001  ->  '0001'
c
      character*20 buffer
      character*4  char4
      real scaled_value
c
      scaled_value = value*scale
      if( scaled_value .le. -10.0 .or. scaled_value .ge. 10.0) then
         cvt_real_4digitchar = 'ZZZZ'
         return
      endif
c
      write(buffer,100) scaled_value
100   format(f6.3)
c
c     123456
c     -b.bbb
c      ^ ^^^      want these guys...
c
      char4(1:1) = buffer(2:2)
      char4(2:2) = buffer(4:4)
      char4(3:3) = buffer(5:5)
      char4(4:4) = buffer(6:6)
c
      cvt_real_4digitchar = char4
      return
      end
      
