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 utilities
c
      subroutine print_array
      implicit none
c
c     Asks user what array to print, then prints it 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
      integer answer, ilen, string_len, istatus
      character*10 buffer
      character*80 errfmt
      character*(PM_MAX_PATHLEN) tmpname
      errfmt = '('' '')'
c
200   call clear_screen
      write(luttyo,errfmt)      ! print any error messages
      errfmt = '('' '')'   ! clear them
      call write_data_menu('Print array 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       4) Is data pure 1D?
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( data_is_trigrid ) then
         call print_tri_array(arrdat(arrind(menu_to_arr(answer))),
     1                   tri_npts, cord,
     1                   data_name(answer), data_units(answer),
     1                   data_file_ext(answer), tmpname, istatus)
         if( istatus .eq. 0 ) then
            ilen = string_len(tmpname)
            errfmt = '('' '',''Wrote file: ' // tmpname(1:ilen) // ''')'
            call beep_terminal
         endif
      else if( is_data_1d(answer) ) then
         errfmt = '('' '',''Cannot make 2D print 1D data'')'
         call beep_terminal
      else
         call ship_array(arrdat(arrind(menu_to_arr(answer))), ni, nj,
     1                   1, ni, 1, nj, 1.0,
     1                   data_name(answer), data_units(answer),
     1                   data_file_ext(answer), tmpname, istatus)
         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_array(data_array, isize, jsize, min_h, max_h,
     1           min_v, max_v, normal, 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 isize, jsize, min_h, max_h, min_v, max_v, istatus
      real data_array(isize, jsize), normal
      character*(*) label, units, ext, filename
c
c     locals
c
      character*50 header
      character*1  ch
      integer ierr, ioerr, nrecl, nb, ilen, string_len
c
c     Sneaky way to get 3rd direction index
      nb = 6/(idisti*idistj)
      ilen = string_len(label)
      write(header,100) label(1:ilen), charb,
     1                  pm_scale_cm2plot*xyz(plane_index,nb)
100   format(a,' at plane ',a1,'= ',f7.3)
c
      filename = binfilestem
      call add_extension(filename,ext)
      nrecl=0
      call pm_open_file(luprint, filename,
     1                  'NEW','FORMATTED','READWRITE','LIST',
     2                  'NONSHARED',nrecl,ioerr,ierr)
      if( ierr .ne. 0 ) goto 1000
      call praray(isize, jsize, data_array(min_h,min_v),
     1            header, units , normal,
     2            (max_h-min_h+1), (max_v-min_v+1),
     3            xyz(min_h,idisti), xyz(min_v,idistj), 1, charh, charv)
      close(unit=luprint)
      istatus = 0
      goto 2000
c
1000  continue
      ilen = string_len(filename)
      write(luttyo,1001) ioerr, filename(1:ilen)
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
      subroutine print_tri_array(data_array, npts, cord,
     1           label, units, ext, filename, istatus)
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'io.cmn'
      include 'units.cmn'
c
      integer npts, istatus
      real data_array(npts), cord(2,npts)
      character*(*) label, units, ext, filename
c
c     locals
c
      character*1  ch
      integer i, ierr, ioerr, nrecl, ilen, string_len
c
      filename = binfilestem
      call add_extension(filename,ext)
      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
      ilen = string_len(label)
      write(luprint,100) label(1:ilen)
100   format('# ',a)
c
      do i=1,npts
         write(luprint,101) cord(1,i), cord(2,i), data_array(i)
101      format(' ',1p3e15.5)
      end do
c
      close(unit=luprint)
      istatus = 0
      goto 2000
c
1000  continue
      ilen = string_len(filename)
      write(luttyo,1001) ioerr, filename(1:ilen)
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

